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         tcRecordSelectors
  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, PolyType,
  20                           Bind(..), MonoBinds(..), Sig,
  21                           MonoType )
  22 import RnHsSyn          ( RenamedTyDecl(..), RenamedConDecl(..) )
  23 import TcHsSyn          ( TcHsBinds(..), TcIdOcc(..), mkHsTyLam )
  24
  25 import TcMonoType       ( tcMonoTypeKind, tcMonoType, tcContext )
  26 import TcType           ( tcInstTyVars, tcInstType )
  27 import TcEnv            ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
  28                           newLocalId
  29                         )
  30 import TcMonad
  31 import TcKind           ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
  32
  33 import Id               ( mkDataCon, dataConSig, mkRecordSelectorId,
  34                           dataConFieldLabels, StrictnessMark(..)
  35                         )
  36 import FieldLabel
  37 import Kind             ( Kind, mkArrowKind, mkBoxedTypeKind )
  38 import SpecEnv          ( SpecEnv(..), nullSpecEnv )
  39 import Name             ( getNameFullName, Name(..) )
  40 import Pretty
  41 import TyCon            ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, tyConDataCons )
  42 import Type             ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy, applyTyCon,
  43                           mkForAllTys, mkFunTy )
  44 import TyVar            ( getTyVarKind, elementOfTyVarSet )
  45 import UniqSet          ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) )
  46 import Util             ( panic, equivClasses )
  47 \end{code}
  48
  49 \begin{code}
  50 tcTyDecl :: RenamedTyDecl -> TcM s TyCon
  51 \end{code}
  52
  53 Type synonym decls
  54 ~~~~~~~~~~~~~~~~~~
  55
  56 \begin{code}
  57 tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
  58   = tcAddSrcLoc src_loc $
  59     tcAddErrCtxt (tySynCtxt tycon_name) $
  60
  61         -- Look up the pieces
  62     tcLookupTyCon tycon_name                    `thenNF_Tc` \ (tycon_kind,  _, rec_tycon) ->
  63     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
  64
  65         -- Look at the rhs
  66     tcMonoTypeKind rhs                          `thenTc` \ (rhs_kind, rhs_ty) ->
  67
  68         -- Unify tycon kind with (k1->...->kn->rhs)
  69     unifyKind tycon_kind
  70         (foldr mkTcArrowKind rhs_kind tyvar_kinds)
  71                                                 `thenTc_`
  72     let
  73         -- Getting the TyCon's kind is a bit of a nuisance.  We can't use the tycon_kind,
  74         -- because that's a TcKind and may not yet be fully unified with other kinds.
  75         -- We could have augmented the tycon environment with a knot-tied kind,
  76         -- but the simplest thing to do seems to be to get the Kind by (lazily)
  77         -- looking at the tyvars and rhs_ty.
  78         result_kind, final_tycon_kind :: Kind   -- NB not TcKind!
  79         result_kind      = getTypeKind rhs_ty
  80         final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars
  81
  82         -- Construct the tycon
  83         tycon = mkSynTyCon (getItsUnique tycon_name)
  84                            (getNameFullName tycon_name)
  85                            final_tycon_kind
  86                            (length tyvar_names)
  87                            rec_tyvars
  88                            rhs_ty
  89     in
  90     returnTc tycon
  91 \end{code}
  92
  93 Algebraic data and newtype decls
  94 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  95
  96 \begin{code}
  97 tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc)
  98   = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
  99
 100 tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
 101   = tcTyDataOrNew NewType  context tycon_name tyvar_names con_decl  derivings pragmas src_loc
 102
 103
 104 tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
 105   = tcAddSrcLoc src_loc $
 106     tcAddErrCtxt (tyDataCtxt tycon_name) $
 107
 108         -- Lookup the pieces
 109     tcLookupTyCon tycon_name                    `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
 110     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
 111     tc_derivs derivings                         `thenNF_Tc` \ derived_classes ->
 112
 113         -- Typecheck the context
 114     tcContext context                           `thenTc` \ ctxt ->
 115
 116         -- Unify tycon kind with (k1->...->kn->Type)
 117     unifyKind tycon_kind
 118         (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
 119                                                 `thenTc_`
 120
 121         -- Walk the condecls
 122     mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
 123                                                 `thenTc` \ con_ids ->
 124     let
 125         -- Construct the tycon
 126         final_tycon_kind :: Kind                -- NB not TcKind!
 127         final_tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind rec_tyvars
 128
 129         tycon = mkDataTyCon (getItsUnique tycon_name)
 130                             final_tycon_kind
 131                             (getNameFullName tycon_name)
 132                             rec_tyvars
 133                             ctxt
 134                             con_ids
 135                             derived_classes
 136                             data_or_new
 137     in
 138     returnTc tycon
 139
 140 tc_derivs Nothing   = returnNF_Tc []
 141 tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
 142
 143 tc_deriv name
 144   = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
 145     returnNF_Tc clas
 146 \end{code}
 147
 148 Generating selector bindings for record delarations
 149 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 150
 151 \begin{code}
 152 tcRecordSelectors :: TyCon -> TcM s ([Id], TcHsBinds s)
 153 tcRecordSelectors tycon
 154   = mapAndUnzipTc (tcRecordSelector tycon) groups       `thenTc` \ (ids, binds) ->
 155     returnTc (ids, SingleBind (NonRecBind (foldr AndMonoBinds EmptyMonoBinds binds)))
 156   where
 157     data_cons = tyConDataCons tycon
 158     fields = [ (con, field) | con   <- data_cons,
 159                               field <- dataConFieldLabels con
 160              ]
 161
 162         -- groups is list of fields that share a common name
 163     groups = equivClasses cmp_name fields
 164     cmp_name (_, field1) (_, field2)
 165         = fieldLabelName field1 `cmp` fieldLabelName field2
 166 \end{code}
 167
 168 We're going to build a record selector that looks like this:
 169
 170         data T a b c = T1 { op :: a, ...}
 171                      | T2 { op :: a, ...}
 172                      | T3
 173
 174         sel :: forall a b c. T a b c -> a
 175         sel = /\ a b c -> \ T1 { sel = x } -> x
 176                             T2 { sel = 2 } -> x
 177
 178 Note that the selector Id itself is used as the field
 179 label; it has to be an Id, you see!
 180
 181 \begin{code}
 182 tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
 183   = panic "tcRecordSelector: don't typecheck"
 184 {-
 185   = let
 186         field_ty   = fieldLabelType first_field_label
 187         field_name = fieldLabelName first_field_label
 188         other_tys  = [fieldLabelType fl | (_, fl) <- fields]
 189         (tyvars, _, _, _) = dataConSig first_con
 190         -- tyvars of first_con may be free in first_ty
 191     in
 192
 193         -- Check that all the fields in the group have the same type
 194         -- This check assumes that all the constructors of a given
 195         -- data type use the same type variables
 196     checkTc (all (eqTy field_ty) other_tys)
 197             (fieldTypeMisMatch field_name)      `thenTc_`
 198
 199         -- Create an Id for the field itself
 200     tcInstTyVars tyvars                 `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
 201     tcInstType tenv field_ty            `thenNF_Tc` \ field_ty' ->
 202     let
 203       data_ty'     = applyTyCon tycon tyvar_tys
 204     in
 205     newLocalId SLIT("x") field_ty'      `thenNF_Tc` \ field_id ->
 206     newLocalId SLIT("r") data_ty'       `thenNF_Tc` \ record_id ->
 207
 208         -- Now build the selector
 209     let
 210       tycon_src_loc = getSrcLoc tycon
 211
 212       selector_ty  = mkForAllTys tyvars' $
 213                      mkFunTy data_ty' $
 214                      field_ty'
 215
 216       selector_id = mkRecordSelectorId first_field_label selector_ty
 217
 218         -- HsSyn is dreadfully verbose for defining the selector!
 219       selector_rhs = mkHsTyLam tyvars' $
 220                      HsLam $
 221                      PatMatch (VarPat record_id) $
 222                      GRHSMatch $
 223                      GRHSsAndBindsOut [OtherwiseGRHS selector_body tycon_src_loc]
 224                                       EmptyBinds field_ty'
 225
 226       selector_body = HsCase (HsVar record_id) (map mk_match fields) tycon_src_loc
 227
 228       mk_match (con_id, field_label)
 229         = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
 230           GRHSMatch $
 231           GRHSsAndBindsOut [OtherwiseGRHS (HsVar field_id)
 232                                           (getSrcLoc (fieldLabelName field_label))]
 233                            EmptyBinds
 234                            field_ty'
 235     in
 236     returnTc (selector_id, VarMonoBind selector_id selector_rhs)
 237 -}
 238 \end{code}
 239
 240 Constructors
 241 ~~~~~~~~~~~~
 242 \begin{code}
 243 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
 244
 245 tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
 246   = tcDataCon tycon tyvars ctxt name btys src_loc
 247
 248 tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
 249   = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
 250
 251 tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
 252   = tcAddSrcLoc src_loc $
 253     tcMonoType ty `thenTc` \ arg_ty ->
 254     let
 255       data_con = mkDataCon (getItsUnique name)
 256                            (getNameFullName name)
 257                            [NotMarkedStrict]
 258                            [{- No labelled fields -}]
 259                            tyvars
 260                            ctxt
 261                            [arg_ty]
 262                            tycon
 263                         -- nullSpecEnv
 264     in
 265     returnTc data_con
 266
 267 tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
 268   = tcAddSrcLoc src_loc $
 269     mapTc tcField fields        `thenTc` \ field_label_infos_s ->
 270     let
 271       field_label_infos = concat field_label_infos_s
 272       stricts           = [strict | (_, _, strict) <- field_label_infos]
 273       arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 274
 275       field_labels      = [ mkFieldLabel name ty tag
 276                           | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags
 277                           ]
 278
 279       data_con = mkDataCon (getItsUnique name)
 280                            (getNameFullName name)
 281                            stricts
 282                            field_labels
 283                            tyvars
 284                            (thinContext arg_tys ctxt)
 285                            arg_tys
 286                            tycon
 287                         -- nullSpecEnv
 288     in
 289     returnTc data_con
 290
 291 tcField (field_label_names, bty)
 292   = tcMonoType (get_ty bty)     `thenTc` \ field_ty ->
 293     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 294
 295 tcDataCon tycon tyvars ctxt name btys src_loc
 296   = tcAddSrcLoc src_loc $
 297     let
 298         stricts = map get_strictness btys
 299         tys     = map get_ty btys
 300     in
 301     mapTc tcMonoType tys `thenTc` \ arg_tys ->
 302     let
 303       data_con = mkDataCon (getItsUnique name)
 304                            (getNameFullName name)
 305                            stricts
 306                            [{- No field labels -}]
 307                            tyvars
 308                            (thinContext arg_tys ctxt)
 309                            arg_tys
 310                            tycon
 311                         -- nullSpecEnv
 312     in
 313     returnTc data_con
 314
 315 -- The context for a data constructor should be limited to
 316 -- the type variables mentioned in the arg_tys
 317 thinContext arg_tys ctxt
 318   = filter in_arg_tys ctxt
 319   where
 320       arg_tyvars = tyVarsOfTypes arg_tys
 321       in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
 322
 323 get_strictness (Banged ty)   = MarkedStrict
 324 get_strictness (Unbanged ty) = NotMarkedStrict
 325
 326 get_ty (Banged ty)   = ty
 327 get_ty (Unbanged ty) = ty
 328 \end{code}
 329
 330
 331
 332 Errors and contexts
 333 ~~~~~~~~~~~~~~~~~~~
 334 \begin{code}
 335 tySynCtxt tycon_name sty
 336   = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
 337
 338 tyDataCtxt tycon_name sty
 339   = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
 340
 341 tyNewCtxt tycon_name sty
 342   = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
 343
 344 fieldTypeMisMatch field_name sty
 345   = ppSep [ppStr "Declared types differ for field", ppr sty field_name]
 346 \end{code}