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(..) )
  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                           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     tcAddErrCtxt (tyDataCtxt tycon_name) $
 117
 118         -- Lookup the pieces
 119     tcLookupTyCon tycon_name                    `thenTc` \ (tycon_kind, _, rec_tycon) ->
 120     mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName)
 121                                  tyvar_names    `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
 122     tc_derivs derivings                         `thenTc` \ derived_classes ->
 123
 124         -- Typecheck the context
 125     tcContext context                           `thenTc` \ ctxt ->
 126
 127         -- Unify tycon kind with (k1->...->kn->Type)
 128     unifyKind tycon_kind
 129         (foldr mkArrowKind mkBoxedTypeKind tyvar_kinds)
 130                                                 `thenTc_`
 131
 132         -- Walk the condecls
 133     mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
 134                                                 `thenTc` \ con_ids ->
 135     let
 136         -- Construct the tycon
 137         final_tycon_kind :: Kind                -- NB not TcKind!
 138         final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars
 139
 140         tycon = mkDataTyCon (getName tycon_name)
 141                             final_tycon_kind
 142                             rec_tyvars
 143                             ctxt
 144                             con_ids
 145                             derived_classes
 146                             Nothing             -- Not a dictionary
 147                             data_or_new
 148                             is_rec
 149     in
 150     returnTc tycon
 151
 152 tc_derivs Nothing   = returnTc []
 153 tc_derivs (Just ds) = mapTc tc_deriv ds
 154
 155 tc_deriv name
 156   = tcLookupClass name `thenTc` \ (_, clas) ->
 157     returnTc clas
 158 \end{code}
 159
 160 Generating constructor/selector bindings for data declarations
 161 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 162
 163 \begin{code}
 164 mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds s)
 165 mkDataBinds [] = returnTc ([], EmptyMonoBinds)
 166 mkDataBinds (tycon : tycons)
 167   | isSynTyCon tycon = mkDataBinds tycons
 168   | otherwise        = mkDataBinds_one tycon    `thenTc` \ (ids1, b1) ->
 169                        mkDataBinds tycons       `thenTc` \ (ids2, b2) ->
 170                        returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
 171
 172 mkDataBinds_one tycon
 173   = ASSERT( isAlgTyCon tycon )
 174     mapTc checkConstructorContext data_cons     `thenTc_`
 175     mapTc (mkRecordSelector tycon) groups       `thenTc` \ sel_ids ->
 176     let
 177         data_ids = data_cons ++ sel_ids
 178
 179         -- For the locally-defined things
 180         -- we need to turn the unfoldings inside the Ids into bindings,
 181         binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id))
 182                 | data_id <- data_ids, isLocallyDefined data_id
 183                 ]
 184     in
 185     returnTc (data_ids, andMonoBinds binds)
 186   where
 187     data_cons = tyConDataCons tycon
 188     fields = [ (con, field) | con   <- data_cons,
 189                               field <- dataConFieldLabels con
 190              ]
 191
 192         -- groups is list of fields that share a common name
 193     groups = equivClasses cmp_name fields
 194     cmp_name (_, field1) (_, field2)
 195         = fieldLabelName field1 `compare` fieldLabelName field2
 196 \end{code}
 197
 198 -- Check that all the types of all the strict arguments are in Eval
 199
 200 \begin{code}
 201 checkConstructorContext con_id
 202   | not (isLocallyDefined con_id)
 203   = returnTc ()
 204
 205   | otherwise   -- It is locally defined
 206   = tcLookupClassByKey evalClassKey     `thenNF_Tc` \ eval_clas ->
 207     let
 208         strict_marks                                       = dataConStrictMarks con_id
 209         (tyvars, theta, ext_tyvars, ext_theta, arg_tys, _) = dataConSig con_id
 210
 211         eval_theta = [ (eval_clas, [arg_ty])
 212                      | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
 213                                                    arg_tys strict_marks
 214                      ]
 215     in
 216     tcAddErrCtxt (evalCtxt con_id eval_theta) $
 217     tcSimplifyCheckThetas theta eval_theta
 218 \end{code}
 219
 220 \begin{code}
 221 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
 222                 -- These fields all have the same name, but are from
 223                 -- different constructors in the data type
 224         -- Check that all the fields in the group have the same type
 225         -- This check assumes that all the constructors of a given
 226         -- data type use the same type variables
 227   = checkTc (all (== field_ty) other_tys)
 228             (fieldTypeMisMatch field_name)      `thenTc_`
 229     returnTc selector_id
 230   where
 231     field_ty   = fieldLabelType first_field_label
 232     field_name = fieldLabelName first_field_label
 233     other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
 234     (tyvars, _, _, _, _, _) = dataConSig first_con
 235     data_ty  = mkTyConApp tycon (mkTyVarTys tyvars)
 236     -- tyvars of first_con may be free in field_ty
 237     -- Now build the selector
 238
 239     selector_ty :: Type
 240     selector_ty  = mkForAllTys tyvars $
 241                    mkFunTy data_ty $
 242                    field_ty
 243
 244     selector_id :: Id
 245     selector_id = mkRecordSelId first_field_label selector_ty
 246 \end{code}
 247
 248 Constructors
 249 ~~~~~~~~~~~~
 250 \begin{code}
 251 tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s Id
 252
 253 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc)
 254   = tcDataCon tycon tyvars ctxt name btys src_loc
 255
 256 tcConDecl tycon tyvars ctxt (ConDecl op ex_ctxt (InfixCon bty1 bty2) src_loc)
 257   = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
 258
 259 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc)
 260   = tcAddSrcLoc src_loc $
 261     tcHsType ty `thenTc` \ arg_ty ->
 262     let
 263       data_con = mkDataCon (getName name)
 264                            [NotMarkedStrict]
 265                            [{- No labelled fields -}]
 266                            tyvars
 267                            ctxt
 268                            [] []        -- Temporary; existential chaps
 269                            [arg_ty]
 270                            tycon
 271     in
 272     returnTc data_con
 273
 274 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc)
 275   = tcAddSrcLoc src_loc $
 276     mapTc tcField fields        `thenTc` \ field_label_infos_s ->
 277     let
 278       field_label_infos = concat field_label_infos_s
 279       stricts           = [strict | (_, _, strict) <- field_label_infos]
 280       arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 281
 282       field_labels      = [ mkFieldLabel (getName name) ty tag
 283                           | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
 284
 285       data_con = mkDataCon (getName name)
 286                            stricts
 287                            field_labels
 288                            tyvars
 289                            (thinContext arg_tys ctxt)
 290                            [] []        -- Temporary; existential chaps
 291                            arg_tys
 292                            tycon
 293     in
 294     returnTc data_con
 295
 296 tcField (field_label_names, bty)
 297   = tcHsType (get_pty bty)      `thenTc` \ field_ty ->
 298     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 299
 300 tcDataCon tycon tyvars ctxt name btys src_loc
 301   = tcAddSrcLoc src_loc $
 302     let
 303         stricts = map get_strictness btys
 304         tys     = map get_pty btys
 305     in
 306     mapTc tcHsType tys `thenTc` \ arg_tys ->
 307     let
 308       data_con = mkDataCon (getName name)
 309                            stricts
 310                            [{- No field labels -}]
 311                            tyvars
 312                            (thinContext arg_tys ctxt)
 313                            [] []        -- Temporary existential chaps
 314                            arg_tys
 315                            tycon
 316     in
 317     returnTc data_con
 318
 319 -- The context for a data constructor should be limited to
 320 -- the type variables mentioned in the arg_tys
 321 thinContext arg_tys ctxt
 322   = filter in_arg_tys ctxt
 323   where
 324       arg_tyvars = tyVarsOfTypes arg_tys
 325       in_arg_tys (clas,tys) = not $ isEmptyTyVarSet $
 326                               tyVarsOfTypes tys `intersectTyVarSets` arg_tyvars
 327
 328 get_strictness (Banged   _) = MarkedStrict
 329 get_strictness (Unbanged _) = NotMarkedStrict
 330
 331 get_pty (Banged ty)   = ty
 332 get_pty (Unbanged ty) = ty
 333 \end{code}
 334
 335
 336
 337 Errors and contexts
 338 ~~~~~~~~~~~~~~~~~~~
 339 \begin{code}
 340 tySynCtxt tycon_name
 341   = hsep [ptext SLIT("In the type declaration for"), quotes (ppr tycon_name)]
 342
 343 tyDataCtxt tycon_name
 344   = hsep [ptext SLIT("In the data declaration for"), quotes (ppr tycon_name)]
 345
 346 tyNewCtxt tycon_name
 347   = hsep [ptext SLIT("In the newtype declaration for"), quotes (ppr tycon_name)]
 348
 349 fieldTypeMisMatch field_name
 350   = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)]
 351
 352 evalCtxt con eval_theta
 353   = hsep [ptext SLIT("When checking the Eval context for constructor:"),
 354            ppr con,
 355            text "::", ppr eval_theta]
 356 \end{code}