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                 -- These fields all have the same name, but are from
 296                 -- different constructors in the data type
 297   = let
 298         field_ty   = fieldLabelType first_field_label
 299         field_name = fieldLabelName first_field_label
 300         other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
 301         (tyvars, _, _, _) = dataConSig first_con
 302         data_ty  = applyTyCon tycon (mkTyVarTys tyvars)
 303         -- tyvars of first_con may be free in field_ty
 304     in
 305
 306         -- Check that all the fields in the group have the same type
 307         -- This check assumes that all the constructors of a given
 308         -- data type use the same type variables
 309     checkTc (all (eqTy field_ty) other_tys)
 310             (fieldTypeMisMatch field_name)      `thenTc_`
 311
 312         -- Create an Id for the field itself
 313     tcInstTyVars tyvars                 `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
 314     tcInstType tenv field_ty            `thenNF_Tc` \ field_ty' ->
 315     let
 316       data_ty' = applyTyCon tycon tyvar_tys
 317     in
 318     newLocalId SLIT("x") field_ty'      `thenNF_Tc` \ field_id ->
 319     newLocalId SLIT("r") data_ty'       `thenNF_Tc` \ record_id ->
 320
 321         -- Now build the selector
 322     let
 323       selector_ty :: Type
 324       selector_ty  = mkForAllTys tyvars $
 325                      mkFunTy data_ty $
 326                      field_ty
 327
 328       selector_id :: Id
 329       selector_id = mkRecordSelId first_field_label selector_ty
 330
 331         -- HsSyn is dreadfully verbose for defining the selector!
 332       selector_rhs = mkHsTyLam tyvars' $
 333                      HsLam $
 334                      PatMatch (VarPat record_id) $
 335                      SimpleMatch $
 336                      selector_body
 337
 338       selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
 339
 340       mk_match (con_id, field_label)
 341         = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
 342           SimpleMatch $
 343           HsVar field_id
 344     in
 345     returnTc (selector_id, if isLocallyDefinedName (getName tycon)
 346                            then VarMonoBind (RealId selector_id) selector_rhs
 347                            else EmptyMonoBinds)
 348 \end{code}
 349
 350 Constructors
 351 ~~~~~~~~~~~~
 352 \begin{code}
 353 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
 354
 355 tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
 356   = tcDataCon tycon tyvars ctxt name btys src_loc
 357
 358 tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
 359   = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
 360
 361 tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
 362   = tcAddSrcLoc src_loc $
 363     tcMonoType ty `thenTc` \ arg_ty ->
 364     let
 365       data_con = mkDataCon (getName name)
 366                            [NotMarkedStrict]
 367                            [{- No labelled fields -}]
 368                            tyvars
 369                            ctxt
 370                            [arg_ty]
 371                            tycon
 372                         -- nullSpecEnv
 373     in
 374     returnTc data_con
 375
 376 tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
 377   = tcAddSrcLoc src_loc $
 378     mapTc tcField fields        `thenTc` \ field_label_infos_s ->
 379     let
 380       field_label_infos = concat field_label_infos_s
 381       stricts           = [strict | (_, _, strict) <- field_label_infos]
 382       arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 383
 384       field_labels      = [ mkFieldLabel (getName name) ty tag
 385                           | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
 386
 387       data_con = mkDataCon (getName name)
 388                            stricts
 389                            field_labels
 390                            tyvars
 391                            (thinContext arg_tys ctxt)
 392                            arg_tys
 393                            tycon
 394                         -- nullSpecEnv
 395     in
 396     returnTc data_con
 397
 398 tcField (field_label_names, bty)
 399   = tcPolyType (get_pty bty)    `thenTc` \ field_ty ->
 400     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 401
 402 tcDataCon tycon tyvars ctxt name btys src_loc
 403   = tcAddSrcLoc src_loc $
 404     let
 405         stricts = map get_strictness btys
 406         tys     = map get_pty btys
 407     in
 408     mapTc tcPolyType tys `thenTc` \ arg_tys ->
 409     let
 410       data_con = mkDataCon (getName name)
 411                            stricts
 412                            [{- No field labels -}]
 413                            tyvars
 414                            (thinContext arg_tys ctxt)
 415                            arg_tys
 416                            tycon
 417                         -- nullSpecEnv
 418     in
 419     returnTc data_con
 420
 421 -- The context for a data constructor should be limited to
 422 -- the type variables mentioned in the arg_tys
 423 thinContext arg_tys ctxt
 424   = filter in_arg_tys ctxt
 425   where
 426       arg_tyvars = tyVarsOfTypes arg_tys
 427       in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
 428
 429 get_strictness (Banged   _) = MarkedStrict
 430 get_strictness (Unbanged _) = NotMarkedStrict
 431
 432 get_pty (Banged ty)   = ty
 433 get_pty (Unbanged ty) = ty
 434 \end{code}
 435
 436
 437
 438 Errors and contexts
 439 ~~~~~~~~~~~~~~~~~~~
 440 \begin{code}
 441 tySynCtxt tycon_name sty
 442   = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
 443
 444 tyDataCtxt tycon_name sty
 445   = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
 446
 447 tyNewCtxt tycon_name sty
 448   = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
 449
 450 fieldTypeMisMatch field_name sty
 451   = ppSep [ppStr "Declared types differ for field", ppr sty field_name]
 452
 453 missingEvalErr con eval_theta sty
 454   = ppCat [ppStr "Missing Eval context for constructor",
 455            ppQuote (ppr sty con),
 456            ppStr ":", ppr sty eval_theta]
 457 \end{code}