ghc/compiler/typecheck/TcTyDecls.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   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                           andMonoBinds
  18                         )
  19 import HsTypes          ( getTyVarName )
  20 import RnHsSyn          ( RenamedTyDecl, RenamedConDecl )
  21 import TcHsSyn          ( mkHsTyLam, mkHsDictLam, tcIdType,
  22                           TcHsBinds, TcMonoBinds
  23                         )
  24 import BasicTypes       ( RecFlag(..), NewOrData(..) )
  25
  26 import Inst             ( newDicts, InstOrigin(..), Inst )
  27 import TcMonoType       ( tcHsTypeKind, tcHsType, tcContext )
  28 import TcSimplify       ( tcSimplifyCheckThetas )
  29 import TcType           ( tcInstTyVars )
  30 import TcEnv            ( TcIdOcc(..), tcInstId,
  31                           tcLookupTyCon, tcLookupTyVar, tcLookupClass,
  32                           newLocalId, newLocalIds, tcLookupClassByKey
  33                         )
  34 import TcMonad
  35 import TcKind           ( TcKind, unifyKind, mkArrowKind, mkBoxedTypeKind )
  36
  37 import Class            ( classInstEnv, Class )
  38 import MkId             ( mkDataCon, mkRecordSelId )
  39 import Id               ( dataConSig, idType,
  40                           dataConFieldLabels, dataConStrictMarks,
  41                           StrictnessMark(..), getIdUnfolding,
  42                           Id
  43                         )
  44 import CoreUnfold       ( getUnfoldingTemplate )
  45 import FieldLabel
  46 import Kind             ( Kind, mkArrowKind, mkBoxedTypeKind )
  47 import Name             ( nameSrcLoc, isLocallyDefined, getSrcLoc,
  48                           OccName(..),
  49                           NamedThing(..)
  50                         )
  51 import Outputable
  52 import TyCon            ( TyCon, mkSynTyCon, mkDataTyCon, isAlgTyCon,
  53                           isSynTyCon, tyConDataCons
  54                         )
  55 import Type             ( typeKind, getTyVar, tyVarsOfTypes, splitSigmaTy,
  56                           mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
  57                           splitFunTys, mkTyVarTy, getTyVar_maybe,
  58                           isUnboxedType, Type, ThetaType
  59                         )
  60 import TyVar            ( tyVarKind, elementOfTyVarSet, intersectTyVarSets, isEmptyTyVarSet,
  61                           TyVar )
  62 import Unique           ( evalClassKey )
  63 import UniqSet          ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet )
  64 import Util             ( equivClasses, zipEqual, nOfThem, panic, assertPanic )
  65 \end{code}
  66
  67 \begin{code}
  68 tcTyDecl :: RecFlag -> RenamedTyDecl -> TcM s TyCon
  69 \end{code}
  70
  71 Type synonym decls
  72 ~~~~~~~~~~~~~~~~~~
  73
  74 \begin{code}
  75 tcTyDecl is_rec (TySynonym tycon_name tyvar_names rhs src_loc)
  76   = tcAddSrcLoc src_loc $
  77     tcAddErrCtxt (tySynCtxt tycon_name) $
  78
  79         -- Look up the pieces
  80     tcLookupTyCon tycon_name                    `thenTc` \ (tycon_kind,  _, rec_tycon) ->
  81     mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) tyvar_names
  82                                                 `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
  83
  84         -- Look at the rhs
  85     tcHsTypeKind rhs                            `thenTc` \ (rhs_kind, rhs_ty) ->
  86
  87         -- Unify tycon kind with (k1->...->kn->rhs)
  88     unifyKind tycon_kind
  89         (foldr mkArrowKind rhs_kind tyvar_kinds)
  90                                                 `thenTc_`
  91     let
  92         -- Getting the TyCon's kind is a bit of a nuisance.  We can't use the tycon_kind,
  93         -- because that's a TcKind and may not yet be fully unified with other kinds.
  94         -- We could have augmented the tycon environment with a knot-tied kind,
  95         -- but the simplest thing to do seems to be to get the Kind by (lazily)
  96         -- looking at the tyvars and rhs_ty.
  97         result_kind, final_tycon_kind :: Kind   -- NB not TcKind!
  98         result_kind      = typeKind rhs_ty
  99         final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars
 100
 101         -- Construct the tycon
 102         tycon = mkSynTyCon (getName tycon_name)
 103                            final_tycon_kind
 104                            (length tyvar_names)
 105                            rec_tyvars
 106                            rhs_ty
 107     in
 108     returnTc tycon
 109 \end{code}
 110
 111 Algebraic data and newtype decls
 112 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 113
 114 \begin{code}
 115 tcTyDecl is_rec (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc)
 116   = tcAddSrcLoc src_loc $
 117     let ctxt = case data_or_new of
 118                  NewType  -> tyNewCtxt tycon_name
 119                  DataType -> tyDataCtxt tycon_name
 120     in
 121     tcAddErrCtxt ctxt $
 122
 123         -- Lookup the pieces
 124     tcLookupTyCon tycon_name                    `thenTc` \ (tycon_kind, _, rec_tycon) ->
 125     mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName)
 126                                  tyvar_names    `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
 127     tc_derivs derivings                         `thenTc` \ derived_classes ->
 128
 129         -- Typecheck the context
 130     tcContext context                           `thenTc` \ ctxt ->
 131
 132         -- Unify tycon kind with (k1->...->kn->Type)
 133     unifyKind tycon_kind
 134         (foldr mkArrowKind mkBoxedTypeKind tyvar_kinds)
 135                                                 `thenTc_`
 136
 137         -- Walk the condecls
 138     mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
 139                                                 `thenTc` \ con_ids ->
 140     let
 141         -- Construct the tycon
 142         final_tycon_kind :: Kind                -- NB not TcKind!
 143         final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars
 144
 145         tycon = mkDataTyCon (getName tycon_name)
 146                             final_tycon_kind
 147                             rec_tyvars
 148                             ctxt
 149                             con_ids
 150                             derived_classes
 151                             Nothing             -- Not a dictionary
 152                             data_or_new
 153                             is_rec
 154     in
 155     returnTc tycon
 156
 157 tc_derivs Nothing   = returnTc []
 158 tc_derivs (Just ds) = mapTc tc_deriv ds
 159
 160 tc_deriv name
 161   = tcLookupClass name `thenTc` \ (_, clas) ->
 162     returnTc clas
 163 \end{code}
 164
 165 Generating constructor/selector bindings for data declarations
 166 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 167
 168 \begin{code}
 169 mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds s)
 170 mkDataBinds [] = returnTc ([], EmptyMonoBinds)
 171 mkDataBinds (tycon : tycons)
 172   | isSynTyCon tycon = mkDataBinds tycons
 173   | otherwise        = mkDataBinds_one tycon    `thenTc` \ (ids1, b1) ->
 174                        mkDataBinds tycons       `thenTc` \ (ids2, b2) ->
 175                        returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
 176
 177 mkDataBinds_one tycon
 178   = ASSERT( isAlgTyCon tycon )
 179     mapTc checkConstructorContext data_cons     `thenTc_`
 180     mapTc (mkRecordSelector tycon) groups       `thenTc` \ sel_ids ->
 181     let
 182         data_ids = data_cons ++ sel_ids
 183
 184         -- For the locally-defined things
 185         -- we need to turn the unfoldings inside the Ids into bindings,
 186         binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id))
 187                 | data_id <- data_ids, isLocallyDefined data_id
 188                 ]
 189     in
 190     returnTc (data_ids, andMonoBinds binds)
 191   where
 192     data_cons = tyConDataCons tycon
 193     fields = [ (con, field) | con   <- data_cons,
 194                               field <- dataConFieldLabels con
 195              ]
 196
 197         -- groups is list of fields that share a common name
 198     groups = equivClasses cmp_name fields
 199     cmp_name (_, field1) (_, field2)
 200         = fieldLabelName field1 `compare` fieldLabelName field2
 201 \end{code}
 202
 203 -- Check that all the types of all the strict arguments are in Eval
 204
 205 \begin{code}
 206 checkConstructorContext con_id
 207   | not (isLocallyDefined con_id)
 208   = returnTc ()
 209
 210   | otherwise   -- It is locally defined
 211   = tcLookupClassByKey evalClassKey     `thenNF_Tc` \ eval_clas ->
 212     let
 213         strict_marks                                       = dataConStrictMarks con_id
 214         (tyvars, theta, ext_tyvars, ext_theta, arg_tys, _) = dataConSig con_id
 215
 216         eval_theta = [ (eval_clas, [arg_ty])
 217                      | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
 218                                                    arg_tys strict_marks
 219                      ]
 220     in
 221     tcAddErrCtxt (evalCtxt con_id eval_theta) $
 222     tcSimplifyCheckThetas theta eval_theta
 223 \end{code}
 224
 225 \begin{code}
 226 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
 227                 -- These fields all have the same name, but are from
 228                 -- different constructors in the data type
 229         -- Check that all the fields in the group have the same type
 230         -- This check assumes that all the constructors of a given
 231         -- data type use the same type variables
 232   = checkTc (all (== field_ty) other_tys)
 233             (fieldTypeMisMatch field_name)      `thenTc_`
 234     returnTc selector_id
 235   where
 236     field_ty   = fieldLabelType first_field_label
 237     field_name = fieldLabelName first_field_label
 238     other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
 239     (tyvars, _, _, _, _, _) = dataConSig first_con
 240     data_ty  = mkTyConApp tycon (mkTyVarTys tyvars)
 241     -- tyvars of first_con may be free in field_ty
 242     -- Now build the selector
 243
 244     selector_ty :: Type
 245     selector_ty  = mkForAllTys tyvars $
 246                    mkFunTy data_ty $
 247                    field_ty
 248
 249     selector_id :: Id
 250     selector_id = mkRecordSelId first_field_label selector_ty
 251 \end{code}
 252
 253 Constructors
 254 ~~~~~~~~~~~~
 255 \begin{code}
 256 tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s Id
 257
 258 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc)
 259   = tcDataCon tycon tyvars ctxt name btys src_loc
 260
 261 tcConDecl tycon tyvars ctxt (ConDecl op ex_ctxt (InfixCon bty1 bty2) src_loc)
 262   = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
 263
 264 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc)
 265   = tcAddSrcLoc src_loc $
 266     tcHsType ty `thenTc` \ arg_ty ->
 267     -- can't allow an unboxed type here, because we're effectively
 268     -- going to remove the constructor while coercing it to a boxed type.
 269     checkTc (not (isUnboxedType arg_ty)) (newTypeUnboxedField ty) `thenTc_`
 270     let
 271       data_con = mkDataCon (getName name)
 272                            [NotMarkedStrict]
 273                            [{- No labelled fields -}]
 274                            tyvars
 275                            ctxt
 276                            [] []        -- Temporary; existential chaps
 277                            [arg_ty]
 278                            tycon
 279     in
 280     returnTc data_con
 281
 282 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc)
 283   = tcAddSrcLoc src_loc $
 284     mapTc tcField fields        `thenTc` \ field_label_infos_s ->
 285     let
 286       field_label_infos = concat field_label_infos_s
 287       stricts           = [strict | (_, _, strict) <- field_label_infos]
 288       arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 289
 290       field_labels      = [ mkFieldLabel (getName name) ty tag
 291                           | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
 292
 293       data_con = mkDataCon (getName name)
 294                            stricts
 295                            field_labels
 296                            tyvars
 297                            (thinContext arg_tys ctxt)
 298                            [] []        -- Temporary; existential chaps
 299                            arg_tys
 300                            tycon
 301     in
 302     returnTc data_con
 303
 304 tcField (field_label_names, bty)
 305   = tcHsType (get_pty bty)      `thenTc` \ field_ty ->
 306     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 307
 308 tcDataCon tycon tyvars ctxt name btys src_loc
 309   = tcAddSrcLoc src_loc $
 310     let
 311         stricts = map get_strictness btys
 312         tys     = map get_pty btys
 313     in
 314     mapTc tcHsType tys `thenTc` \ arg_tys ->
 315     let
 316       data_con = mkDataCon (getName name)
 317                            stricts
 318                            [{- No field labels -}]
 319                            tyvars
 320                            (thinContext arg_tys ctxt)
 321                            [] []        -- Temporary existential chaps
 322                            arg_tys
 323                            tycon
 324     in
 325     returnTc data_con
 326
 327 -- The context for a data constructor should be limited to
 328 -- the type variables mentioned in the arg_tys
 329 thinContext arg_tys ctxt
 330   = filter in_arg_tys ctxt
 331   where
 332       arg_tyvars = tyVarsOfTypes arg_tys
 333       in_arg_tys (clas,tys) = not $ isEmptyTyVarSet $
 334                               tyVarsOfTypes tys `intersectTyVarSets` arg_tyvars
 335
 336 get_strictness (Banged   _) = MarkedStrict
 337 get_strictness (Unbanged _) = NotMarkedStrict
 338
 339 get_pty (Banged ty)   = ty
 340 get_pty (Unbanged ty) = ty
 341 \end{code}
 342
 343
 344
 345 Errors and contexts
 346 ~~~~~~~~~~~~~~~~~~~
 347 \begin{code}
 348 tySynCtxt tycon_name
 349   = hsep [ptext SLIT("In the type declaration for"), quotes (ppr tycon_name)]
 350
 351 tyDataCtxt tycon_name
 352   = hsep [ptext SLIT("In the data declaration for"), quotes (ppr tycon_name)]
 353
 354 tyNewCtxt tycon_name
 355   = hsep [ptext SLIT("In the newtype declaration for"), quotes (ppr tycon_name)]
 356
 357 fieldTypeMisMatch field_name
 358   = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)]
 359
 360 newTypeUnboxedField ty
 361   = sep [ptext SLIT("Newtype constructor field has an unboxed type:"),
 362          quotes (ppr ty)]
 363
 364 evalCtxt con eval_theta
 365   = hsep [ptext SLIT("When checking the Eval context for constructor:"),
 366            ppr con,
 367            text "::", ppr eval_theta]
 368 \end{code}