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                           isNewTyCon, tyConDataCons
  53                         )
  54 import Type             ( typeKind, getTyVar, tyVarsOfTypes, eqTy,
  55                           applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
  56                           splitFunTy, mkTyVarTy, getTyVar_maybe
  57                         )
  58 import TyVar            ( tyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} )
  59 import Unique           ( Unique {- instance Eq -}, evalClassKey )
  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      = typeKind rhs_ty
  95         final_tycon_kind = foldr (mkArrowKind . tyVarKind) 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 . tyVarKind) 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 || isNewTyCon 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 sel_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 T1 [a,b] [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
 225                                         `thenNF_Tc` \ args ->
 226
 227         -- Check that all the types of all the strict arguments are in Data.
 228         -- This is trivially true of everything except type variables, for
 229         -- 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, uniqueOf clas == evalClassKey]
 238
 239         check_data arg = case getTyVar_maybe (tcIdType arg) of
 240                            Nothing    -> returnTc ()    -- Not a tyvar, so OK
 241                            Just tyvar -> checkTc (tyvar `elem` data_tyvars) (missingDataErr tyvar)
 242     in
 243     mapTc check_data strict_args        `thenTc_`
 244
 245         -- Build the data constructor
 246     let
 247         con_rhs = mkHsTyLam tyvars $
 248                   mkHsDictLam dicts $
 249                   mk_pat_match args $
 250                   mk_case strict_args $
 251                   HsCon con_id (mkTyVarTys tyvars) (map HsVar args)
 252
 253         mk_pat_match []         body = body
 254         mk_pat_match (arg:args) body = HsLam (PatMatch (VarPat arg) (SimpleMatch (mk_pat_match args body)))
 255
 256         mk_case [] body = body
 257         mk_case (arg:args) body = HsCase (HsVar arg)
 258                                          [PatMatch (VarPat arg) (SimpleMatch (mk_case args body))]
 259                                          src_loc
 260
 261         src_loc = nameSrcLoc (getName con_id)
 262     in
 263
 264     returnTc (con_id, VarMonoBind (RealId con_id) con_rhs)
 265 \end{code}
 266
 267 We're going to build a record selector that looks like this:
 268
 269         data T a b c = T1 { op :: a, ...}
 270                      | T2 { op :: a, ...}
 271                      | T3
 272
 273         sel :: forall a b c. T a b c -> a
 274         sel = /\ a b c -> \ T1 { sel = x } -> x
 275                             T2 { sel = 2 } -> x
 276
 277 Note that the selector Id itself is used as the field
 278 label; it has to be an Id, you see!
 279
 280 \begin{code}
 281 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
 282   = let
 283         field_ty   = fieldLabelType first_field_label
 284         field_name = fieldLabelName first_field_label
 285         other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
 286         (tyvars, _, _, _) = dataConSig first_con
 287         data_ty  = applyTyCon tycon (mkTyVarTys tyvars)
 288         -- tyvars of first_con may be free in field_ty
 289     in
 290
 291         -- Check that all the fields in the group have the same type
 292         -- This check assumes that all the constructors of a given
 293         -- data type use the same type variables
 294     checkTc (all (eqTy field_ty) other_tys)
 295             (fieldTypeMisMatch field_name)      `thenTc_`
 296
 297         -- Create an Id for the field itself
 298     tcInstTyVars tyvars                 `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
 299     tcInstType tenv field_ty            `thenNF_Tc` \ field_ty' ->
 300     let
 301       data_ty' = applyTyCon tycon tyvar_tys
 302     in
 303     newLocalId SLIT("x") field_ty'      `thenNF_Tc` \ field_id ->
 304     newLocalId SLIT("r") data_ty'       `thenNF_Tc` \ record_id ->
 305
 306         -- Now build the selector
 307     let
 308       selector_ty :: Type
 309       selector_ty  = mkForAllTys tyvars $
 310                      mkFunTy data_ty $
 311                      field_ty
 312
 313       selector_id :: Id
 314       selector_id = mkRecordSelId first_field_label selector_ty
 315
 316         -- HsSyn is dreadfully verbose for defining the selector!
 317       selector_rhs = mkHsTyLam tyvars' $
 318                      HsLam $
 319                      PatMatch (VarPat record_id) $
 320                      SimpleMatch $
 321                      selector_body
 322
 323       selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
 324
 325       mk_match (con_id, field_label)
 326         = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
 327           SimpleMatch $
 328           HsVar field_id
 329     in
 330     returnTc (selector_id, if isLocallyDefinedName (getName tycon)
 331                            then VarMonoBind (RealId selector_id) selector_rhs
 332                            else EmptyMonoBinds)
 333 \end{code}
 334
 335 Constructors
 336 ~~~~~~~~~~~~
 337 \begin{code}
 338 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
 339
 340 tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
 341   = tcDataCon tycon tyvars ctxt name btys src_loc
 342
 343 tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
 344   = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
 345
 346 tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
 347   = tcAddSrcLoc src_loc $
 348     tcMonoType ty `thenTc` \ arg_ty ->
 349     let
 350       data_con = mkDataCon (getName name)
 351                            [NotMarkedStrict]
 352                            [{- No labelled fields -}]
 353                            tyvars
 354                            ctxt
 355                            [arg_ty]
 356                            tycon
 357                         -- nullSpecEnv
 358     in
 359     returnTc data_con
 360
 361 tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
 362   = tcAddSrcLoc src_loc $
 363     mapTc tcField fields        `thenTc` \ field_label_infos_s ->
 364     let
 365       field_label_infos = concat field_label_infos_s
 366       stricts           = [strict | (_, _, strict) <- field_label_infos]
 367       arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 368
 369       field_labels      = [ mkFieldLabel (getName name) ty tag
 370                           | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags
 371                           ]
 372
 373       data_con = mkDataCon (getName name)
 374                            stricts
 375                            field_labels
 376                            tyvars
 377                            (thinContext arg_tys ctxt)
 378                            arg_tys
 379                            tycon
 380                         -- nullSpecEnv
 381     in
 382     returnTc data_con
 383
 384 tcField (field_label_names, bty)
 385   = tcPolyType (get_pty bty)    `thenTc` \ field_ty ->
 386     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 387
 388 tcDataCon tycon tyvars ctxt name btys src_loc
 389   = tcAddSrcLoc src_loc $
 390     let
 391         stricts = map get_strictness btys
 392         tys     = map get_pty btys
 393     in
 394     mapTc tcPolyType tys `thenTc` \ arg_tys ->
 395     let
 396       data_con = mkDataCon (getName name)
 397                            stricts
 398                            [{- No field labels -}]
 399                            tyvars
 400                            (thinContext arg_tys ctxt)
 401                            arg_tys
 402                            tycon
 403                         -- nullSpecEnv
 404     in
 405     returnTc data_con
 406
 407 -- The context for a data constructor should be limited to
 408 -- the type variables mentioned in the arg_tys
 409 thinContext arg_tys ctxt
 410   = filter in_arg_tys ctxt
 411   where
 412       arg_tyvars = tyVarsOfTypes arg_tys
 413       in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
 414
 415 get_strictness (Banged   _) = MarkedStrict
 416 get_strictness (Unbanged _) = NotMarkedStrict
 417
 418 get_pty (Banged ty)   = ty
 419 get_pty (Unbanged ty) = ty
 420 \end{code}
 421
 422
 423
 424 Errors and contexts
 425 ~~~~~~~~~~~~~~~~~~~
 426 \begin{code}
 427 tySynCtxt tycon_name sty
 428   = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
 429
 430 tyDataCtxt tycon_name sty
 431   = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
 432
 433 tyNewCtxt tycon_name sty
 434   = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
 435
 436 fieldTypeMisMatch field_name sty
 437   = ppSep [ppStr "Declared types differ for field", ppr sty field_name]
 438
 439 missingDataErr tyvar sty
 440   = ppStr "Missing `data' (???)" -- ToDo: improve
 441 \end{code}