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 import Ubiq{-uitous-}
  16
  17 import HsSyn            ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
  18                           Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
  19                           HsBinds(..), HsLit, Stmt, Qual, 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
 254         -- Build the data constructor
 255     let
 256         con_rhs = mkHsTyLam tc_tyvars $
 257                   mkHsDictLam dicts $
 258                   mk_pat_match args $
 259                   mk_case (zipEqual "strict_args" args strict_marks) $
 260                   HsCon con_id (mkTyVarTys tc_tyvars) (map HsVar args)
 261
 262         mk_pat_match []         body = body
 263         mk_pat_match (arg:args) body = HsLam $
 264                                        PatMatch (VarPat arg) $
 265                                        SimpleMatch (mk_pat_match args body)
 266
 267         mk_case [] body = body
 268         mk_case ((arg,MarkedStrict):args) body = HsCase (HsVar arg)
 269                                                          [PatMatch (VarPat arg) $
 270                                                           SimpleMatch (mk_case args body)]
 271                                                          src_loc
 272         mk_case (_:args) body = mk_case args body
 273
 274         src_loc = nameSrcLoc (getName con_id)
 275     in
 276
 277     returnTc (con_id, VarMonoBind (RealId con_id) con_rhs)
 278 \end{code}
 279
 280 We're going to build a record selector that looks like this:
 281
 282         data T a b c = T1 { op :: a, ...}
 283                      | T2 { op :: a, ...}
 284                      | T3
 285
 286         sel :: forall a b c. T a b c -> a
 287         sel = /\ a b c -> \ T1 { sel = x } -> x
 288                             T2 { sel = 2 } -> x
 289
 290 Note that the selector Id itself is used as the field
 291 label; it has to be an Id, you see!
 292
 293 \begin{code}
 294 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
 295   = let
 296         field_ty   = fieldLabelType first_field_label
 297         field_name = fieldLabelName first_field_label
 298         other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
 299         (tyvars, _, _, _) = dataConSig first_con
 300         data_ty  = applyTyCon tycon (mkTyVarTys tyvars)
 301         -- tyvars of first_con may be free in field_ty
 302     in
 303
 304         -- Check that all the fields in the group have the same type
 305         -- This check assumes that all the constructors of a given
 306         -- data type use the same type variables
 307     checkTc (all (eqTy field_ty) other_tys)
 308             (fieldTypeMisMatch field_name)      `thenTc_`
 309
 310         -- Create an Id for the field itself
 311     tcInstTyVars tyvars                 `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
 312     tcInstType tenv field_ty            `thenNF_Tc` \ field_ty' ->
 313     let
 314       data_ty' = applyTyCon tycon tyvar_tys
 315     in
 316     newLocalId SLIT("x") field_ty'      `thenNF_Tc` \ field_id ->
 317     newLocalId SLIT("r") data_ty'       `thenNF_Tc` \ record_id ->
 318
 319         -- Now build the selector
 320     let
 321       selector_ty :: Type
 322       selector_ty  = mkForAllTys tyvars $
 323                      mkFunTy data_ty $
 324                      field_ty
 325
 326       selector_id :: Id
 327       selector_id = mkRecordSelId first_field_label selector_ty
 328
 329         -- HsSyn is dreadfully verbose for defining the selector!
 330       selector_rhs = mkHsTyLam tyvars' $
 331                      HsLam $
 332                      PatMatch (VarPat record_id) $
 333                      SimpleMatch $
 334                      selector_body
 335
 336       selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
 337
 338       mk_match (con_id, field_label)
 339         = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
 340           SimpleMatch $
 341           HsVar field_id
 342     in
 343     returnTc (selector_id, if isLocallyDefinedName (getName tycon)
 344                            then VarMonoBind (RealId selector_id) selector_rhs
 345                            else EmptyMonoBinds)
 346 \end{code}
 347
 348 Constructors
 349 ~~~~~~~~~~~~
 350 \begin{code}
 351 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
 352
 353 tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
 354   = tcDataCon tycon tyvars ctxt name btys src_loc
 355
 356 tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
 357   = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
 358
 359 tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
 360   = tcAddSrcLoc src_loc $
 361     tcMonoType ty `thenTc` \ arg_ty ->
 362     let
 363       data_con = mkDataCon (getName name)
 364                            [NotMarkedStrict]
 365                            [{- No labelled fields -}]
 366                            tyvars
 367                            ctxt
 368                            [arg_ty]
 369                            tycon
 370                         -- nullSpecEnv
 371     in
 372     returnTc data_con
 373
 374 tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
 375   = tcAddSrcLoc src_loc $
 376     mapTc tcField fields        `thenTc` \ field_label_infos_s ->
 377     let
 378       field_label_infos = concat field_label_infos_s
 379       stricts           = [strict | (_, _, strict) <- field_label_infos]
 380       arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 381
 382       field_labels      = [ mkFieldLabel (getName name) ty tag
 383                           | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
 384
 385       data_con = mkDataCon (getName name)
 386                            stricts
 387                            field_labels
 388                            tyvars
 389                            (thinContext arg_tys ctxt)
 390                            arg_tys
 391                            tycon
 392                         -- nullSpecEnv
 393     in
 394     returnTc data_con
 395
 396 tcField (field_label_names, bty)
 397   = tcPolyType (get_pty bty)    `thenTc` \ field_ty ->
 398     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 399
 400 tcDataCon tycon tyvars ctxt name btys src_loc
 401   = tcAddSrcLoc src_loc $
 402     let
 403         stricts = map get_strictness btys
 404         tys     = map get_pty btys
 405     in
 406     mapTc tcPolyType tys `thenTc` \ arg_tys ->
 407     let
 408       data_con = mkDataCon (getName name)
 409                            stricts
 410                            [{- No field labels -}]
 411                            tyvars
 412                            (thinContext arg_tys ctxt)
 413                            arg_tys
 414                            tycon
 415                         -- nullSpecEnv
 416     in
 417     returnTc data_con
 418
 419 -- The context for a data constructor should be limited to
 420 -- the type variables mentioned in the arg_tys
 421 thinContext arg_tys ctxt
 422   = filter in_arg_tys ctxt
 423   where
 424       arg_tyvars = tyVarsOfTypes arg_tys
 425       in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
 426
 427 get_strictness (Banged   _) = MarkedStrict
 428 get_strictness (Unbanged _) = NotMarkedStrict
 429
 430 get_pty (Banged ty)   = ty
 431 get_pty (Unbanged ty) = ty
 432 \end{code}
 433
 434
 435
 436 Errors and contexts
 437 ~~~~~~~~~~~~~~~~~~~
 438 \begin{code}
 439 tySynCtxt tycon_name sty
 440   = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
 441
 442 tyDataCtxt tycon_name sty
 443   = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
 444
 445 tyNewCtxt tycon_name sty
 446   = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
 447
 448 fieldTypeMisMatch field_name sty
 449   = ppSep [ppStr "Declared types differ for field", ppr sty field_name]
 450
 451 missingEvalErr con eval_theta sty
 452   = ppCat [ppStr "Missing Eval context for constructor",
 453            ppQuote (ppr sty con),
 454            ppStr ":", ppr sty eval_theta]
 455 \end{code}