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 #include "HsVersions.h"
   8
   9 module TcTyDecls (
  10         tcTyDecl,
  11         tcConDecl,
  12         mkDataBinds
  13     ) where
  14
  15 IMP_Ubiq(){-uitous-}
  16
  17 import HsSyn            ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
  18                           Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
  19                           HsBinds(..), HsLit, Stmt, Qualifier, ArithSeqInfo,
  20                           PolyType, Fake, InPat,
  21                           Bind(..), MonoBinds(..), Sig,
  22                           MonoType )
  23 import RnHsSyn          ( RenamedTyDecl(..), RenamedConDecl(..),
  24                           RnName{-instance Outputable-}
  25                         )
  26 import TcHsSyn          ( mkHsTyLam, mkHsDictLam, tcIdType,
  27                           TcHsBinds(..), TcIdOcc(..)
  28                         )
  29 import Inst             ( newDicts, InstOrigin(..), Inst )
  30 import TcMonoType       ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext )
  31 import TcSimplify       ( tcSimplifyThetas )
  32 import TcType           ( tcInstTyVars, tcInstType, tcInstId )
  33 import TcEnv            ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
  34                           newLocalId, newLocalIds, tcLookupClassByKey
  35                         )
  36 import TcMonad          hiding ( rnMtoTcM )
  37 import TcKind           ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
  38
  39 import PprType          ( GenClass, GenType{-instance Outputable-} )
  40 import Class            ( GenClass{-instance Eq-}, classInstEnv )
  41 import Id               ( mkDataCon, dataConSig, mkRecordSelId, idType,
  42                           dataConFieldLabels, dataConStrictMarks,
  43                           StrictnessMark(..),
  44                           GenId{-instance NamedThing-}
  45                         )
  46 import FieldLabel
  47 import Kind             ( Kind, mkArrowKind, mkBoxedTypeKind )
  48 import SpecEnv          ( SpecEnv(..), nullSpecEnv )
  49 import Name             ( nameSrcLoc, isLocallyDefinedName, getSrcLoc,
  50                           Name{-instance Ord3-}
  51                         )
  52 import Outputable       ( Outputable(..), interpp'SP )
  53 import Pretty
  54 import TyCon            ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon,
  55                           isNewTyCon, isSynTyCon, tyConDataCons
  56                         )
  57 import Type             ( GenType, -- instances
  58                           typeKind, getTyVar, tyVarsOfTypes, eqTy, splitSigmaTy,
  59                           applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
  60                           splitFunTy, mkTyVarTy, getTyVar_maybe
  61                         )
  62 import PprType          ( GenTyVar{-instance Outputable-}{-ToDo:possibly rm-} )
  63 import TyVar            ( tyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} )
  64 import Unique           ( Unique {- instance Eq -}, evalClassKey )
  65 import UniqSet          ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) )
  66 import Util             ( equivClasses, zipEqual, nOfThem, panic, assertPanic )
  67 \end{code}
  68
  69 \begin{code}
  70 tcTyDecl :: RenamedTyDecl -> TcM s TyCon
  71 \end{code}
  72
  73 Type synonym decls
  74 ~~~~~~~~~~~~~~~~~~
  75
  76 \begin{code}
  77 tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
  78   = tcAddSrcLoc src_loc $
  79     tcAddErrCtxt (tySynCtxt tycon_name) $
  80
  81         -- Look up the pieces
  82     tcLookupTyCon tycon_name                    `thenNF_Tc` \ (tycon_kind,  _, rec_tycon) ->
  83     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
  84
  85         -- Look at the rhs
  86     tcMonoTypeKind rhs                          `thenTc` \ (rhs_kind, rhs_ty) ->
  87
  88         -- Unify tycon kind with (k1->...->kn->rhs)
  89     unifyKind tycon_kind
  90         (foldr mkTcArrowKind rhs_kind tyvar_kinds)
  91                                                 `thenTc_`
  92     let
  93         -- Getting the TyCon's kind is a bit of a nuisance.  We can't use the tycon_kind,
  94         -- because that's a TcKind and may not yet be fully unified with other kinds.
  95         -- We could have augmented the tycon environment with a knot-tied kind,
  96         -- but the simplest thing to do seems to be to get the Kind by (lazily)
  97         -- looking at the tyvars and rhs_ty.
  98         result_kind, final_tycon_kind :: Kind   -- NB not TcKind!
  99         result_kind      = typeKind rhs_ty
 100         final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars
 101
 102         -- Construct the tycon
 103         tycon = mkSynTyCon (getName tycon_name)
 104                            final_tycon_kind
 105                            (length tyvar_names)
 106                            rec_tyvars
 107                            rhs_ty
 108     in
 109     returnTc tycon
 110 \end{code}
 111
 112 Algebraic data and newtype decls
 113 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 114
 115 \begin{code}
 116 tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc)
 117   = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
 118
 119 tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
 120   = tcTyDataOrNew NewType  context tycon_name tyvar_names con_decl  derivings pragmas src_loc
 121
 122
 123 tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
 124   = tcAddSrcLoc src_loc $
 125     tcAddErrCtxt (tyDataCtxt tycon_name) $
 126
 127         -- Lookup the pieces
 128     tcLookupTyCon tycon_name                    `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
 129     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
 130     tc_derivs derivings                         `thenNF_Tc` \ derived_classes ->
 131
 132         -- Typecheck the context
 133     tcContext context                           `thenTc` \ ctxt ->
 134
 135         -- Unify tycon kind with (k1->...->kn->Type)
 136     unifyKind tycon_kind
 137         (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
 138                                                 `thenTc_`
 139
 140         -- Walk the condecls
 141     mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
 142                                                 `thenTc` \ con_ids ->
 143     let
 144         -- Construct the tycon
 145         final_tycon_kind :: Kind                -- NB not TcKind!
 146         final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars
 147
 148         tycon = mkDataTyCon (getName tycon_name)
 149                             final_tycon_kind
 150                             rec_tyvars
 151                             ctxt
 152                             con_ids
 153                             derived_classes
 154                             data_or_new
 155     in
 156     returnTc tycon
 157
 158 tc_derivs Nothing   = returnNF_Tc []
 159 tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
 160
 161 tc_deriv name
 162   = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
 163     returnNF_Tc clas
 164 \end{code}
 165
 166 Generating constructor/selector bindings for data declarations
 167 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 168
 169 \begin{code}
 170 mkDataBinds :: [TyCon] -> TcM s ([Id], TcHsBinds s)
 171 mkDataBinds [] = returnTc ([], EmptyBinds)
 172 mkDataBinds (tycon : tycons)
 173   | isSynTyCon tycon = mkDataBinds tycons
 174   | otherwise        = mkDataBinds_one tycon    `thenTc` \ (ids1, b1) ->
 175                        mkDataBinds tycons       `thenTc` \ (ids2, b2) ->
 176                        returnTc (ids1++ids2, b1 `ThenBinds` b2)
 177
 178 mkDataBinds_one tycon
 179   = ASSERT( isDataTyCon tycon || isNewTyCon tycon )
 180     mapAndUnzipTc mkConstructor data_cons               `thenTc` \ (con_ids, con_binds) ->
 181     mapAndUnzipTc (mkRecordSelector tycon) groups       `thenTc` \ (sel_ids, sel_binds) ->
 182     returnTc (con_ids ++ sel_ids,
 183               SingleBind $ NonRecBind $
 184               foldr AndMonoBinds
 185                     (foldr AndMonoBinds EmptyMonoBinds sel_binds)
 186                     con_binds
 187     )
 188   where
 189     data_cons = tyConDataCons tycon
 190     fields = [ (con, field) | con   <- data_cons,
 191                               field <- dataConFieldLabels con
 192              ]
 193
 194         -- groups is list of fields that share a common name
 195     groups = equivClasses cmp_name fields
 196     cmp_name (_, field1) (_, field2)
 197         = fieldLabelName field1 `cmp` fieldLabelName field2
 198 \end{code}
 199
 200 We're going to build a constructor that looks like:
 201
 202         data (Data a, C b) =>  T a b = T1 !a !Int b
 203
 204         T1 = /\ a b ->
 205              \d1::Data a, d2::C b ->
 206              \p q r -> case p of { p ->
 207                        case q of { q ->
 208                        HsCon T1 [a,b] [p,q,r]}}
 209
 210 Notice that
 211
 212 * d2 is thrown away --- a context in a data decl is used to make sure
 213   one *could* construct dictionaries at the site the constructor
 214   is used, but the dictionary isn't actually used.
 215
 216 * We have to check that we can construct Data dictionaries for
 217   the types a and Int.  Once we've done that we can throw d1 away too.
 218
 219 * We use (case p of ...) to evaluate p, rather than "seq" because
 220   all that matters is that the arguments are evaluated.  "seq" is
 221   very careful to preserve evaluation order, which we don't need
 222   to be here.
 223
 224 \begin{code}
 225 mkConstructor con_id
 226   | not (isLocallyDefinedName (getName con_id))
 227   = returnTc (con_id, EmptyMonoBinds)
 228
 229   | otherwise   -- It is locally defined
 230   = tcInstId con_id                     `thenNF_Tc` \ (tc_tyvars, tc_theta, tc_tau) ->
 231     newDicts DataDeclOrigin tc_theta    `thenNF_Tc` \ (_, dicts) ->
 232     let
 233         (tc_arg_tys, tc_result_ty) = splitFunTy tc_tau
 234         n_args = length tc_arg_tys
 235     in
 236     newLocalIds (nOfThem n_args SLIT("con")) tc_arg_tys `thenNF_Tc` \ args ->
 237
 238         -- Check that all the types of all the strict arguments are in Eval
 239     tcLookupClassByKey evalClassKey     `thenNF_Tc` \ eval_clas ->
 240     let
 241         (_,theta,tau) = splitSigmaTy (idType con_id)
 242         (arg_tys, _)  = splitFunTy tau
 243         strict_marks  = dataConStrictMarks con_id
 244         eval_theta    = [ (eval_clas,arg_ty)
 245                         | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
 246                                                         arg_tys strict_marks
 247                         ]
 248     in
 249     tcSimplifyThetas classInstEnv theta eval_theta      `thenTc` \ eval_theta' ->
 250     checkTc (null eval_theta')
 251             (missingEvalErr con_id eval_theta')         `thenTc_`
 252
 253         -- Build the data constructor
 254     let
 255         con_rhs = mkHsTyLam tc_tyvars $
 256                   mkHsDictLam dicts $
 257                   mk_pat_match args $
 258                   mk_case (zipEqual "strict_args" args strict_marks) $
 259                   HsCon con_id (mkTyVarTys tc_tyvars) (map HsVar args)
 260
 261         mk_pat_match []         body = body
 262         mk_pat_match (arg:args) body = HsLam $
 263                                        PatMatch (VarPat arg) $
 264                                        SimpleMatch (mk_pat_match args body)
 265
 266         mk_case [] body = body
 267         mk_case ((arg,MarkedStrict):args) body = HsCase (HsVar arg)
 268                                                          [PatMatch (VarPat arg) $
 269                                                           SimpleMatch (mk_case args body)]
 270                                                          src_loc
 271         mk_case (_:args) body = mk_case args body
 272
 273         src_loc = nameSrcLoc (getName con_id)
 274     in
 275
 276     returnTc (con_id, VarMonoBind (RealId con_id) con_rhs)
 277 \end{code}
 278
 279 We're going to build a record selector that looks like this:
 280
 281         data T a b c = T1 { op :: a, ...}
 282                      | T2 { op :: a, ...}
 283                      | T3
 284
 285         sel :: forall a b c. T a b c -> a
 286         sel = /\ a b c -> \ T1 { sel = x } -> x
 287                             T2 { sel = 2 } -> x
 288
 289 Note that the selector Id itself is used as the field
 290 label; it has to be an Id, you see!
 291
 292 \begin{code}
 293 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
 294   = let
 295         field_ty   = fieldLabelType first_field_label
 296         field_name = fieldLabelName first_field_label
 297         other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
 298         (tyvars, _, _, _) = dataConSig first_con
 299         data_ty  = applyTyCon tycon (mkTyVarTys tyvars)
 300         -- tyvars of first_con may be free in field_ty
 301     in
 302
 303         -- Check that all the fields in the group have the same type
 304         -- This check assumes that all the constructors of a given
 305         -- data type use the same type variables
 306     checkTc (all (eqTy field_ty) other_tys)
 307             (fieldTypeMisMatch field_name)      `thenTc_`
 308
 309         -- Create an Id for the field itself
 310     tcInstTyVars tyvars                 `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
 311     tcInstType tenv field_ty            `thenNF_Tc` \ field_ty' ->
 312     let
 313       data_ty' = applyTyCon tycon tyvar_tys
 314     in
 315     newLocalId SLIT("x") field_ty'      `thenNF_Tc` \ field_id ->
 316     newLocalId SLIT("r") data_ty'       `thenNF_Tc` \ record_id ->
 317
 318         -- Now build the selector
 319     let
 320       selector_ty :: Type
 321       selector_ty  = mkForAllTys tyvars $
 322                      mkFunTy data_ty $
 323                      field_ty
 324
 325       selector_id :: Id
 326       selector_id = mkRecordSelId first_field_label selector_ty
 327
 328         -- HsSyn is dreadfully verbose for defining the selector!
 329       selector_rhs = mkHsTyLam tyvars' $
 330                      HsLam $
 331                      PatMatch (VarPat record_id) $
 332                      SimpleMatch $
 333                      selector_body
 334
 335       selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
 336
 337       mk_match (con_id, field_label)
 338         = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
 339           SimpleMatch $
 340           HsVar field_id
 341     in
 342     returnTc (selector_id, if isLocallyDefinedName (getName tycon)
 343                            then VarMonoBind (RealId selector_id) selector_rhs
 344                            else EmptyMonoBinds)
 345 \end{code}
 346
 347 Constructors
 348 ~~~~~~~~~~~~
 349 \begin{code}
 350 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
 351
 352 tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
 353   = tcDataCon tycon tyvars ctxt name btys src_loc
 354
 355 tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
 356   = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
 357
 358 tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
 359   = tcAddSrcLoc src_loc $
 360     tcMonoType ty `thenTc` \ arg_ty ->
 361     let
 362       data_con = mkDataCon (getName name)
 363                            [NotMarkedStrict]
 364                            [{- No labelled fields -}]
 365                            tyvars
 366                            ctxt
 367                            [arg_ty]
 368                            tycon
 369                         -- nullSpecEnv
 370     in
 371     returnTc data_con
 372
 373 tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
 374   = tcAddSrcLoc src_loc $
 375     mapTc tcField fields        `thenTc` \ field_label_infos_s ->
 376     let
 377       field_label_infos = concat field_label_infos_s
 378       stricts           = [strict | (_, _, strict) <- field_label_infos]
 379       arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 380
 381       field_labels      = [ mkFieldLabel (getName name) ty tag
 382                           | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
 383
 384       data_con = mkDataCon (getName name)
 385                            stricts
 386                            field_labels
 387                            tyvars
 388                            (thinContext arg_tys ctxt)
 389                            arg_tys
 390                            tycon
 391                         -- nullSpecEnv
 392     in
 393     returnTc data_con
 394
 395 tcField (field_label_names, bty)
 396   = tcPolyType (get_pty bty)    `thenTc` \ field_ty ->
 397     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 398
 399 tcDataCon tycon tyvars ctxt name btys src_loc
 400   = tcAddSrcLoc src_loc $
 401     let
 402         stricts = map get_strictness btys
 403         tys     = map get_pty btys
 404     in
 405     mapTc tcPolyType tys `thenTc` \ arg_tys ->
 406     let
 407       data_con = mkDataCon (getName name)
 408                            stricts
 409                            [{- No field labels -}]
 410                            tyvars
 411                            (thinContext arg_tys ctxt)
 412                            arg_tys
 413                            tycon
 414                         -- nullSpecEnv
 415     in
 416     returnTc data_con
 417
 418 -- The context for a data constructor should be limited to
 419 -- the type variables mentioned in the arg_tys
 420 thinContext arg_tys ctxt
 421   = filter in_arg_tys ctxt
 422   where
 423       arg_tyvars = tyVarsOfTypes arg_tys
 424       in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
 425
 426 get_strictness (Banged   _) = MarkedStrict
 427 get_strictness (Unbanged _) = NotMarkedStrict
 428
 429 get_pty (Banged ty)   = ty
 430 get_pty (Unbanged ty) = ty
 431 \end{code}
 432
 433
 434
 435 Errors and contexts
 436 ~~~~~~~~~~~~~~~~~~~
 437 \begin{code}
 438 tySynCtxt tycon_name sty
 439   = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
 440
 441 tyDataCtxt tycon_name sty
 442   = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
 443
 444 tyNewCtxt tycon_name sty
 445   = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
 446
 447 fieldTypeMisMatch field_name sty
 448   = ppSep [ppStr "Declared types differ for field", ppr sty field_name]
 449
 450 missingEvalErr con eval_theta sty
 451   = ppCat [ppStr "Missing Eval context for constructor",
 452            ppQuote (ppr sty con),
 453            ppStr ":", ppr sty eval_theta]
 454 \end{code}