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