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                           SYN_IE(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                           GenTyVar{-instance Outputable-}{-ToDo:possibly rm-}
  41                         )
  42 import Class            ( GenClass{-instance Eq-}, classInstEnv )
  43 import Id               ( mkDataCon, dataConSig, mkRecordSelId, idType,
  44                           dataConFieldLabels, dataConStrictMarks,
  45                           StrictnessMark(..),
  46                           GenId{-instance NamedThing-}
  47                         )
  48 import FieldLabel
  49 import Kind             ( Kind, mkArrowKind, mkBoxedTypeKind )
  50 import SpecEnv          ( SpecEnv, nullSpecEnv )
  51 import Name             ( nameSrcLoc, isLocallyDefinedName, getSrcLoc,
  52                           Name{-instance Ord3-}
  53                         )
  54 import Outputable       ( Outputable(..), interpp'SP )
  55 import Pretty
  56 import TyCon            ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon,
  57                           isNewTyCon, isSynTyCon, tyConDataCons
  58                         )
  59 import Type             ( GenType, -- instances
  60                           typeKind, getTyVar, tyVarsOfTypes, eqTy, splitSigmaTy,
  61                           applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
  62                           splitFunTy, mkTyVarTy, getTyVar_maybe
  63                         )
  64 import TyVar            ( tyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} )
  65 import Unique           ( Unique {- instance Eq -}, evalClassKey )
  66 import UniqSet          ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, SYN_IE(UniqSet) )
  67 import Util             ( equivClasses, zipEqual, nOfThem, panic, assertPanic )
  68 \end{code}
  69
  70 \begin{code}
  71 tcTyDecl :: RenamedTyDecl -> TcM s TyCon
  72 \end{code}
  73
  74 Type synonym decls
  75 ~~~~~~~~~~~~~~~~~~
  76
  77 \begin{code}
  78 tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
  79   = tcAddSrcLoc src_loc $
  80     tcAddErrCtxt (tySynCtxt tycon_name) $
  81
  82         -- Look up the pieces
  83     tcLookupTyCon tycon_name                    `thenNF_Tc` \ (tycon_kind,  _, rec_tycon) ->
  84     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
  85
  86         -- Look at the rhs
  87     tcMonoTypeKind rhs                          `thenTc` \ (rhs_kind, rhs_ty) ->
  88
  89         -- Unify tycon kind with (k1->...->kn->rhs)
  90     unifyKind tycon_kind
  91         (foldr mkTcArrowKind rhs_kind tyvar_kinds)
  92                                                 `thenTc_`
  93     let
  94         -- Getting the TyCon's kind is a bit of a nuisance.  We can't use the tycon_kind,
  95         -- because that's a TcKind and may not yet be fully unified with other kinds.
  96         -- We could have augmented the tycon environment with a knot-tied kind,
  97         -- but the simplest thing to do seems to be to get the Kind by (lazily)
  98         -- looking at the tyvars and rhs_ty.
  99         result_kind, final_tycon_kind :: Kind   -- NB not TcKind!
 100         result_kind      = typeKind rhs_ty
 101         final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars
 102
 103         -- Construct the tycon
 104         tycon = mkSynTyCon (getName tycon_name)
 105                            final_tycon_kind
 106                            (length tyvar_names)
 107                            rec_tyvars
 108                            rhs_ty
 109     in
 110     returnTc tycon
 111 \end{code}
 112
 113 Algebraic data and newtype decls
 114 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 115
 116 \begin{code}
 117 tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc)
 118   = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
 119
 120 tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
 121   = tcTyDataOrNew NewType  context tycon_name tyvar_names con_decl  derivings pragmas src_loc
 122
 123
 124 tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
 125   = tcAddSrcLoc src_loc $
 126     tcAddErrCtxt (tyDataCtxt tycon_name) $
 127
 128         -- Lookup the pieces
 129     tcLookupTyCon tycon_name                    `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
 130     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
 131     tc_derivs derivings                         `thenNF_Tc` \ derived_classes ->
 132
 133         -- Typecheck the context
 134     tcContext context                           `thenTc` \ ctxt ->
 135
 136         -- Unify tycon kind with (k1->...->kn->Type)
 137     unifyKind tycon_kind
 138         (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
 139                                                 `thenTc_`
 140
 141         -- Walk the condecls
 142     mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
 143                                                 `thenTc` \ con_ids ->
 144     let
 145         -- Construct the tycon
 146         final_tycon_kind :: Kind                -- NB not TcKind!
 147         final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars
 148
 149         tycon = mkDataTyCon (getName tycon_name)
 150                             final_tycon_kind
 151                             rec_tyvars
 152                             ctxt
 153                             con_ids
 154                             derived_classes
 155                             data_or_new
 156     in
 157     returnTc tycon
 158
 159 tc_derivs Nothing   = returnNF_Tc []
 160 tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
 161
 162 tc_deriv name
 163   = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
 164     returnNF_Tc clas
 165 \end{code}
 166
 167 Generating constructor/selector bindings for data declarations
 168 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 169
 170 \begin{code}
 171 mkDataBinds :: [TyCon] -> TcM s ([Id], TcHsBinds s)
 172 mkDataBinds [] = returnTc ([], EmptyBinds)
 173 mkDataBinds (tycon : tycons)
 174   | isSynTyCon tycon = mkDataBinds tycons
 175   | otherwise        = mkDataBinds_one tycon    `thenTc` \ (ids1, b1) ->
 176                        mkDataBinds tycons       `thenTc` \ (ids2, b2) ->
 177                        returnTc (ids1++ids2, b1 `ThenBinds` b2)
 178
 179 mkDataBinds_one tycon
 180   = ASSERT( isDataTyCon tycon || isNewTyCon tycon )
 181     mapAndUnzipTc mkConstructor data_cons               `thenTc` \ (con_ids, con_binds) ->
 182     mapAndUnzipTc (mkRecordSelector tycon) groups       `thenTc` \ (sel_ids, sel_binds) ->
 183     returnTc (con_ids ++ sel_ids,
 184               SingleBind $ NonRecBind $
 185               foldr AndMonoBinds
 186                     (foldr AndMonoBinds EmptyMonoBinds sel_binds)
 187                     con_binds
 188     )
 189   where
 190     data_cons = tyConDataCons tycon
 191     fields = [ (con, field) | con   <- data_cons,
 192                               field <- dataConFieldLabels con
 193              ]
 194
 195         -- groups is list of fields that share a common name
 196     groups = equivClasses cmp_name fields
 197     cmp_name (_, field1) (_, field2)
 198         = fieldLabelName field1 `cmp` fieldLabelName field2
 199 \end{code}
 200
 201 We're going to build a constructor that looks like:
 202
 203         data (Data a, C b) =>  T a b = T1 !a !Int b
 204
 205         T1 = /\ a b ->
 206              \d1::Data a, d2::C b ->
 207              \p q r -> case p of { p ->
 208                        case q of { q ->
 209                        HsCon T1 [a,b] [p,q,r]}}
 210
 211 Notice that
 212
 213 * d2 is thrown away --- a context in a data decl is used to make sure
 214   one *could* construct dictionaries at the site the constructor
 215   is used, but the dictionary isn't actually used.
 216
 217 * We have to check that we can construct Data dictionaries for
 218   the types a and Int.  Once we've done that we can throw d1 away too.
 219
 220 * We use (case p of ...) to evaluate p, rather than "seq" because
 221   all that matters is that the arguments are evaluated.  "seq" is
 222   very careful to preserve evaluation order, which we don't need
 223   to be here.
 224
 225 \begin{code}
 226 mkConstructor con_id
 227   | not (isLocallyDefinedName (getName con_id))
 228   = returnTc (con_id, EmptyMonoBinds)
 229
 230   | otherwise   -- It is locally defined
 231   = tcInstId con_id                     `thenNF_Tc` \ (tc_tyvars, tc_theta, tc_tau) ->
 232     newDicts DataDeclOrigin tc_theta    `thenNF_Tc` \ (_, dicts) ->
 233     let
 234         (tc_arg_tys, tc_result_ty) = splitFunTy tc_tau
 235         n_args = length tc_arg_tys
 236     in
 237     newLocalIds (nOfThem n_args SLIT("con")) tc_arg_tys `thenNF_Tc` \ args ->
 238
 239         -- Check that all the types of all the strict arguments are in Eval
 240     tcLookupClassByKey evalClassKey     `thenNF_Tc` \ eval_clas ->
 241     let
 242         (_,theta,tau) = splitSigmaTy (idType con_id)
 243         (arg_tys, _)  = splitFunTy tau
 244         strict_marks  = dataConStrictMarks con_id
 245         eval_theta    = [ (eval_clas,arg_ty)
 246                         | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
 247                                                         arg_tys strict_marks
 248                         ]
 249     in
 250     tcSimplifyThetas classInstEnv theta eval_theta      `thenTc` \ eval_theta' ->
 251     checkTc (null eval_theta')
 252             (missingEvalErr con_id eval_theta')         `thenTc_`
 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}