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