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