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                           RnName{-instance Outputable-}
  24                         )
  25 import TcHsSyn          ( TcHsBinds(..), TcIdOcc(..), mkHsTyLam )
  26
  27 import TcMonoType       ( tcMonoTypeKind, tcMonoType, tcContext )
  28 import TcType           ( tcInstTyVars, tcInstType )
  29 import TcEnv            ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
  30                           newLocalId
  31                         )
  32 import TcMonad
  33 import TcKind           ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
  34
  35 import Id               ( mkDataCon, dataConSig, mkRecordSelId,
  36                           dataConFieldLabels, StrictnessMark(..)
  37                         )
  38 import FieldLabel
  39 import Kind             ( Kind, mkArrowKind, mkBoxedTypeKind )
  40 import SpecEnv          ( SpecEnv(..), nullSpecEnv )
  41 import Name             ( Name{-instance Ord3-} )
  42 import Pretty
  43 import TyCon            ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, tyConDataCons )
  44 import Type             ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy, applyTyCon,
  45                           mkForAllTys, mkFunTy )
  46 import TyVar            ( getTyVarKind, elementOfTyVarSet )
  47 import UniqSet          ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) )
  48 import Util             ( panic, equivClasses )
  49 \end{code}
  50
  51 \begin{code}
  52 tcTyDecl :: RenamedTyDecl -> TcM s TyCon
  53 \end{code}
  54
  55 Type synonym decls
  56 ~~~~~~~~~~~~~~~~~~
  57
  58 \begin{code}
  59 tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
  60   = tcAddSrcLoc src_loc $
  61     tcAddErrCtxt (tySynCtxt tycon_name) $
  62
  63         -- Look up the pieces
  64     tcLookupTyCon tycon_name                    `thenNF_Tc` \ (tycon_kind,  _, rec_tycon) ->
  65     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
  66
  67         -- Look at the rhs
  68     tcMonoTypeKind rhs                          `thenTc` \ (rhs_kind, rhs_ty) ->
  69
  70         -- Unify tycon kind with (k1->...->kn->rhs)
  71     unifyKind tycon_kind
  72         (foldr mkTcArrowKind rhs_kind tyvar_kinds)
  73                                                 `thenTc_`
  74     let
  75         -- Getting the TyCon's kind is a bit of a nuisance.  We can't use the tycon_kind,
  76         -- because that's a TcKind and may not yet be fully unified with other kinds.
  77         -- We could have augmented the tycon environment with a knot-tied kind,
  78         -- but the simplest thing to do seems to be to get the Kind by (lazily)
  79         -- looking at the tyvars and rhs_ty.
  80         result_kind, final_tycon_kind :: Kind   -- NB not TcKind!
  81         result_kind      = getTypeKind rhs_ty
  82         final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars
  83
  84         -- Construct the tycon
  85         tycon = mkSynTyCon (getName tycon_name)
  86                            final_tycon_kind
  87                            (length tyvar_names)
  88                            rec_tyvars
  89                            rhs_ty
  90     in
  91     returnTc tycon
  92 \end{code}
  93
  94 Algebraic data and newtype decls
  95 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  96
  97 \begin{code}
  98 tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc)
  99   = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
 100
 101 tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
 102   = tcTyDataOrNew NewType  context tycon_name tyvar_names con_decl  derivings pragmas src_loc
 103
 104
 105 tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
 106   = tcAddSrcLoc src_loc $
 107     tcAddErrCtxt (tyDataCtxt tycon_name) $
 108
 109         -- Lookup the pieces
 110     tcLookupTyCon tycon_name                    `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
 111     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
 112     tc_derivs derivings                         `thenNF_Tc` \ derived_classes ->
 113
 114         -- Typecheck the context
 115     tcContext context                           `thenTc` \ ctxt ->
 116
 117         -- Unify tycon kind with (k1->...->kn->Type)
 118     unifyKind tycon_kind
 119         (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
 120                                                 `thenTc_`
 121
 122         -- Walk the condecls
 123     mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
 124                                                 `thenTc` \ con_ids ->
 125     let
 126         -- Construct the tycon
 127         final_tycon_kind :: Kind                -- NB not TcKind!
 128         final_tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind rec_tyvars
 129
 130         tycon = mkDataTyCon (getName tycon_name)
 131                             final_tycon_kind
 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 = mkRecordSelId 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 (getName name)
 256                            [NotMarkedStrict]
 257                            [{- No labelled fields -}]
 258                            tyvars
 259                            ctxt
 260                            [arg_ty]
 261                            tycon
 262                         -- nullSpecEnv
 263     in
 264     returnTc data_con
 265
 266 tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
 267   = tcAddSrcLoc src_loc $
 268     mapTc tcField fields        `thenTc` \ field_label_infos_s ->
 269     let
 270       field_label_infos = concat field_label_infos_s
 271       stricts           = [strict | (_, _, strict) <- field_label_infos]
 272       arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 273
 274       field_labels      = [ mkFieldLabel (getName name) ty tag
 275                           | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags
 276                           ]
 277
 278       data_con = mkDataCon (getName name)
 279                            stricts
 280                            field_labels
 281                            tyvars
 282                            (thinContext arg_tys ctxt)
 283                            arg_tys
 284                            tycon
 285                         -- nullSpecEnv
 286     in
 287     returnTc data_con
 288
 289 tcField (field_label_names, bty)
 290   = tcMonoType (get_ty bty)     `thenTc` \ field_ty ->
 291     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 292
 293 tcDataCon tycon tyvars ctxt name btys src_loc
 294   = tcAddSrcLoc src_loc $
 295     let
 296         stricts = map get_strictness btys
 297         tys     = map get_ty btys
 298     in
 299     mapTc tcMonoType tys `thenTc` \ arg_tys ->
 300     let
 301       data_con = mkDataCon (getName name)
 302                            stricts
 303                            [{- No field labels -}]
 304                            tyvars
 305                            (thinContext arg_tys ctxt)
 306                            arg_tys
 307                            tycon
 308                         -- nullSpecEnv
 309     in
 310     returnTc data_con
 311
 312 -- The context for a data constructor should be limited to
 313 -- the type variables mentioned in the arg_tys
 314 thinContext arg_tys ctxt
 315   = filter in_arg_tys ctxt
 316   where
 317       arg_tyvars = tyVarsOfTypes arg_tys
 318       in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
 319
 320 get_strictness (Banged ty)   = MarkedStrict
 321 get_strictness (Unbanged ty) = NotMarkedStrict
 322
 323 get_ty (Banged ty)   = ty
 324 get_ty (Unbanged ty) = ty
 325 \end{code}
 326
 327
 328
 329 Errors and contexts
 330 ~~~~~~~~~~~~~~~~~~~
 331 \begin{code}
 332 tySynCtxt tycon_name sty
 333   = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
 334
 335 tyDataCtxt tycon_name sty
 336   = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
 337
 338 tyNewCtxt tycon_name sty
 339   = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
 340
 341 fieldTypeMisMatch field_name sty
 342   = ppSep [ppStr "Declared types differ for field", ppr sty field_name]
 343 \end{code}