ghc/compiler/typecheck/TcTyClsDecls.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 \section[TcTyClsDecls]{Typecheck type and class declarations}
   5
   6 \begin{code}
   7 module TcTyClsDecls (
   8         tcTyAndClassDecls
   9     ) where
  10
  11 #include "HsVersions.h"
  12
  13 import HsSyn            ( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
  14                           ConDecl(..),   Sig(..), BangType(..), HsBang(..),
  15                           tyClDeclTyVars, getBangType, getBangStrictness, isSynDecl,
  16                           LTyClDecl, tcdName, LHsTyVarBndr
  17                         )
  18 import BasicTypes       ( RecFlag(..), NewOrData(..), StrictnessMark(..) )
  19 import HscTypes         ( implicitTyThings )
  20 import BuildTyCl        ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon )
  21 import TcRnMonad
  22 import TcEnv            ( TcTyThing(..), TyThing(..),
  23                           tcLookupLocated, tcLookupLocatedGlobal,
  24                           tcExtendGlobalEnv, tcExtendKindEnv,
  25                           tcExtendRecEnv, tcLookupTyVar )
  26 import TcTyDecls        ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles )
  27 import TcClassDcl       ( tcClassSigs, tcAddDeclCtxt )
  28 import TcHsType         ( kcHsTyVars, kcHsLiftedSigType, kcHsSigType, kcHsType,
  29                           kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext )
  30 import TcMType          ( newKindVar, checkValidTheta, checkValidType, checkFreeness,
  31                           UserTypeCtxt(..), SourceTyCtxt(..) )
  32 import TcUnify          ( unifyKind )
  33 import TcType           ( TcKind, ThetaType, TcType, tyVarsOfType,
  34                           mkArrowKind, liftedTypeKind,
  35                           tcSplitSigmaTy, tcEqType )
  36 import Type             ( splitTyConApp_maybe, pprThetaArrow, pprParendType )
  37 import FieldLabel       ( fieldLabelName, fieldLabelType )
  38 import Generics         ( validGenericMethodType, canDoGenerics )
  39 import Class            ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
  40 import TyCon            ( TyCon, ArgVrcs, DataConDetails(..),
  41                           tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
  42                           tyConTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName )
  43 import DataCon          ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
  44 import Var              ( TyVar, idType, idName )
  45 import VarSet           ( elemVarSet )
  46 import Name             ( Name )
  47 import Outputable
  48 import Util             ( zipLazy, isSingleton, notNull )
  49 import List             ( partition )
  50 import SrcLoc           ( Located(..), unLoc, getLoc )
  51 import ListSetOps       ( equivClasses )
  52 import Digraph          ( SCC(..) )
  53 import CmdLineOpts      ( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) )
  54 \end{code}
  55
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 \subsection{Type checking for type and class declarations}
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 Dealing with a group
  64 ~~~~~~~~~~~~~~~~~~~~
  65 Consider a mutually-recursive group, binding
  66 a type constructor T and a class C.
  67
  68 Step 1:         getInitialKind
  69         Construct a KindEnv by binding T and C to a kind variable
  70
  71 Step 2:         kcTyClDecl
  72         In that environment, do a kind check
  73
  74 Step 3: Zonk the kinds
  75
  76 Step 4:         buildTyConOrClass
  77         Construct an environment binding T to a TyCon and C to a Class.
  78         a) Their kinds comes from zonking the relevant kind variable
  79         b) Their arity (for synonyms) comes direct from the decl
  80         c) The funcional dependencies come from the decl
  81         d) The rest comes a knot-tied binding of T and C, returned from Step 4
  82         e) The variances of the tycons in the group is calculated from
  83                 the knot-tied stuff
  84
  85 Step 5:         tcTyClDecl1
  86         In this environment, walk over the decls, constructing the TyCons and Classes.
  87         This uses in a strict way items (a)-(c) above, which is why they must
  88         be constructed in Step 4. Feed the results back to Step 4.
  89         For this step, pass the is-recursive flag as the wimp-out flag
  90         to tcTyClDecl1.
  91
  92
  93 Step 6:         Extend environment
  94         We extend the type environment with bindings not only for the TyCons and Classes,
  95         but also for their "implicit Ids" like data constructors and class selectors
  96
  97 Step 7:         checkValidTyCl
  98         For a recursive group only, check all the decls again, just
  99         to check all the side conditions on validity.  We could not
 100         do this before because we were in a mutually recursive knot.
 101
 102
 103 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 104 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 105
 106 \begin{code}
 107 tcTyAndClassDecls :: [LTyClDecl Name]
 108                    -> TcM TcGblEnv      -- Input env extended by types and classes
 109                                         -- and their implicit Ids,DataCons
 110 tcTyAndClassDecls decls
 111   = do  {       -- First check for cyclic type synonysm or classes
 112                 -- See notes with checkCycleErrs
 113           checkCycleErrs decls
 114
 115         ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
 116           do    { let { -- Calculate variances and rec-flag
 117                       ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls }
 118
 119                         -- Extend the global env with the knot-tied results
 120                         -- for data types and classes
 121                         --
 122                         -- We must populate the environment with the loop-tied T's right
 123                         -- away, because the kind checker may "fault in" some type
 124                         -- constructors that recursively mention T
 125                 ; let { gbl_things = mkGlobalThings alg_decls rec_alg_tyclss }
 126                 ; tcExtendRecEnv gbl_things $ do
 127
 128                         -- Kind-check the declarations
 129                 { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
 130
 131                 ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss)
 132                       ; calc_rec  = calcRecFlags     rec_alg_tyclss
 133                       ; tc_decl   = addLocM (tcTyClDecl calc_vrcs calc_rec) }
 134                         -- Type-check the type synonyms, and extend the envt
 135                 ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls
 136                 ; tcExtendGlobalEnv syn_tycons $ do
 137
 138                         -- Type-check the data types and classes
 139                 { alg_tyclss <- mappM tc_decl kc_alg_decls
 140                 ; return (syn_tycons, alg_tyclss)
 141             }}})
 142         -- Finished with knot-tying now
 143         -- Extend the environment with the finished things
 144         ; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do
 145
 146         -- Perform the validity check
 147         { traceTc (text "ready for validity check")
 148         ; mappM_ (addLocM checkValidTyCl) decls
 149         ; traceTc (text "done")
 150
 151         -- Add the implicit things;
 152         -- we want them in the environment because
 153         -- they may be mentioned in interface files
 154         ; let { implicit_things = concatMap implicitTyThings alg_tyclss }
 155         ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things))
 156         ; tcExtendGlobalEnv implicit_things getGblEnv
 157     }}
 158
 159 mkGlobalThings :: [LTyClDecl Name]      -- The decls
 160                -> [TyThing]             -- Knot-tied, in 1-1 correspondence with the decls
 161                -> [(Name,TyThing)]
 162 -- Driven by the Decls, and treating the TyThings lazily
 163 -- make a TypeEnv for the new things
 164 mkGlobalThings decls things
 165   = map mk_thing (decls `zipLazy` things)
 166   where
 167     mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl))
 168          = (name, AClass cl)
 169     mk_thing (L _ decl, ~(ATyCon tc))
 170          = (tcdName decl, ATyCon tc)
 171 \end{code}
 172
 173
 174 %************************************************************************
 175 %*                                                                      *
 176                 Kind checking
 177 %*                                                                      *
 178 %************************************************************************
 179
 180 We need to kind check all types in the mutually recursive group
 181 before we know the kind of the type variables.  For example:
 182
 183 class C a where
 184    op :: D b => a -> b -> b
 185
 186 class D c where
 187    bop :: (Monad c) => ...
 188
 189 Here, the kind of the locally-polymorphic type variable "b"
 190 depends on *all the uses of class D*.  For example, the use of
 191 Monad c in bop's type signature means that D must have kind Type->Type.
 192
 193 However type synonyms work differently.  They can have kinds which don't
 194 just involve (->) and *:
 195         type R = Int#           -- Kind #
 196         type S a = Array# a     -- Kind * -> #
 197         type T a b = (# a,b #)  -- Kind * -> * -> (# a,b #)
 198 So we must infer their kinds from their right-hand sides *first* and then
 199 use them, whereas for the mutually recursive data types D we bring into
 200 scope kind bindings D -> k, where k is a kind variable, and do inference.
 201
 202 \begin{code}
 203 kcTyClDecls syn_decls alg_decls
 204   = do  {       -- First extend the kind env with each data
 205                 -- type and class, mapping them to a type variable
 206           alg_kinds <- mappM getInitialKind alg_decls
 207         ; tcExtendKindEnv alg_kinds $ do
 208
 209                 -- Now kind-check the type synonyms, in dependency order
 210                 -- We do these differently to data type and classes,
 211                 -- because a type synonym can be an unboxed type
 212                 --      type Foo = Int#
 213                 -- and a kind variable can't unify with UnboxedTypeKind
 214                 -- So we infer their kinds in dependency order
 215         { (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls)
 216         ; tcExtendKindEnv syn_kinds $  do
 217
 218                 -- Now kind-check the data type and class declarations,
 219                 -- returning kind-annotated decls
 220         { kc_alg_decls <- mappM (wrapLocM kcTyClDecl) alg_decls
 221
 222         ; return (kc_syn_decls, kc_alg_decls) }}}
 223
 224 ------------------------------------------------------------------------
 225 getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
 226
 227 getInitialKind decl
 228  = newKindVar                   `thenM` \ kind  ->
 229    returnM (unLoc (tcdLName (unLoc decl)), kind)
 230
 231 ----------------
 232 kcSynDecls :: [SCC (LTyClDecl Name)]
 233            -> TcM ([LTyClDecl Name],    -- Kind-annotated decls
 234                    [(Name,TcKind)])     -- Kind bindings
 235 kcSynDecls []
 236   = return ([], [])
 237 kcSynDecls (group : groups)
 238   = do  { (decl,  nk)  <- kcSynDecl group
 239         ; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups)
 240         ; return (decl:decls, nk:nks) }
 241
 242 ----------------
 243 kcSynDecl :: SCC (LTyClDecl Name)
 244            -> TcM (LTyClDecl Name,      -- Kind-annotated decls
 245                    (Name,TcKind))       -- Kind bindings
 246 kcSynDecl (AcyclicSCC ldecl@(L loc decl))
 247   = tcAddDeclCtxt decl  $
 248     kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
 249     do { traceTc (text "kcd1" <+> ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
 250                         <+> brackets (ppr k_tvs))
 251        ; (k_rhs, rhs_kind) <- kcHsType (tcdSynRhs decl)
 252        ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))
 253        ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs
 254        ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
 255                  (unLoc (tcdLName decl), tc_kind)) })
 256
 257 kcSynDecl (CyclicSCC decls)
 258   = do { recSynErr decls; failM }       -- Fail here to avoid error cascade
 259                                         -- of out-of-scope tycons
 260
 261 ------------------------------------------------------------------------
 262 kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
 263         -- Not used for type synonyms (see kcSynDecl)
 264
 265 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
 266   = kcTyClDeclBody decl $ \ tvs' ->
 267     do  { ctxt' <- kcHsContext ctxt
 268         ; cons' <- mappM (wrapLocM kc_con_decl) cons
 269         ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) }
 270   where
 271     kc_con_decl (ConDecl name ex_tvs ex_ctxt details)
 272       = kcHsTyVars ex_tvs               $ \ ex_tvs' ->
 273         do { ex_ctxt' <- kcHsContext ex_ctxt
 274            ; details' <- kc_con_details details
 275            ; return (ConDecl name ex_tvs' ex_ctxt' details')}
 276
 277     kc_con_details (PrefixCon btys)
 278         = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') }
 279     kc_con_details (InfixCon bty1 bty2)
 280         = do { bty1' <- kc_larg_ty bty1; bty2' <- kc_larg_ty bty2; return (InfixCon bty1' bty2') }
 281     kc_con_details (RecCon fields)
 282         = do { fields' <- mappM kc_field fields; return (RecCon fields') }
 283
 284     kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') }
 285
 286     kc_larg_ty = wrapLocM kc_arg_ty
 287
 288     kc_arg_ty (BangType str ty) = do { ty' <- kc_arg_ty_body ty; return (BangType str ty') }
 289     kc_arg_ty_body = case new_or_data of
 290                          DataType -> kcHsSigType
 291                          NewType  -> kcHsLiftedSigType
 292             -- Can't allow an unlifted type for newtypes, because we're effectively
 293             -- going to remove the constructor while coercing it to a lifted type.
 294
 295 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt,  tcdSigs = sigs})
 296   = kcTyClDeclBody decl $ \ tvs' ->
 297     do  { ctxt' <- kcHsContext ctxt
 298         ; sigs' <- mappM (wrapLocM kc_sig) sigs
 299         ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) }
 300   where
 301     kc_sig (Sig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
 302                                 ; return (Sig nm op_ty') }
 303     kc_sig other_sig          = return other_sig
 304
 305 kcTyClDecl decl@(ForeignType {})
 306   = return decl
 307
 308 kcTyClDeclBody :: TyClDecl Name
 309                -> ([LHsTyVarBndr Name] -> TcM a)
 310                -> TcM a
 311   -- Extend the env with bindings for the tyvars, taken from
 312   -- the kind of the tycon/class.  Give it to the thing inside, and
 313   -- check the result kind matches
 314 kcTyClDeclBody decl thing_inside
 315   = tcAddDeclCtxt decl          $
 316     kcHsTyVars (tyClDeclTyVars decl)    $ \ kinded_tvs ->
 317     do  { tc_ty_thing <- tcLookupLocated (tcdLName decl)
 318         ; let tc_kind = case tc_ty_thing of { AThing k -> k }
 319         ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind)
 320                                    liftedTypeKind kinded_tvs)
 321         ; thing_inside kinded_tvs }
 322
 323 kindedTyVarKind (L _ (KindedTyVar _ k)) = k
 324 \end{code}
 325
 326
 327 %************************************************************************
 328 %*                                                                      *
 329 \subsection{Type checking}
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 \begin{code}
 334 tcSynDecls :: (Name -> ArgVrcs) -> [LTyClDecl Name] -> TcM [TyThing]
 335 tcSynDecls calc_vrcs [] = return []
 336 tcSynDecls calc_vrcs (decl : decls)
 337   = do { syn_tc <- addLocM (tcSynDecl calc_vrcs) decl
 338        ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls calc_vrcs decls)
 339        ; return (syn_tc : syn_tcs) }
 340
 341 tcSynDecl calc_vrcs
 342   (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
 343   = tcTyVarBndrs tvs            $ \ tvs' -> do
 344     { traceTc (text "tcd1" <+> ppr tc_name)
 345     ; rhs_ty' <- tcHsKindedType rhs_ty
 346     ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' (calc_vrcs tc_name))) }
 347
 348 --------------------
 349 tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag)
 350            -> TyClDecl Name -> TcM TyThing
 351
 352 tcTyClDecl calc_vrcs calc_isrec decl
 353   = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl)
 354
 355 tcTyClDecl1 calc_vrcs calc_isrec
 356   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
 357            tcdLName = L _ tc_name, tcdCons = cons})
 358   = tcTyVarBndrs tvs            $ \ tvs' -> do
 359   { ctxt'        <- tcHsKindedContext ctxt
 360   ; want_generic <- doptM Opt_Generics
 361   ; tycon <- fixM (\ tycon -> do
 362         { cons' <- mappM (addLocM (tcConDecl new_or_data tycon tvs' ctxt')) cons
 363         ; buildAlgTyCon new_or_data tc_name tvs' ctxt'
 364                         (DataCons cons') arg_vrcs is_rec
 365                         (want_generic && canDoGenerics cons')
 366         })
 367   ; return (ATyCon tycon)
 368   }
 369   where
 370     arg_vrcs = calc_vrcs tc_name
 371     is_rec   = calc_isrec tc_name
 372
 373 tcTyClDecl1 calc_vrcs calc_isrec
 374   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
 375               tcdCtxt = ctxt, tcdMeths = meths,
 376               tcdFDs = fundeps, tcdSigs = sigs} )
 377   = tcTyVarBndrs tvs            $ \ tvs' -> do
 378   { ctxt' <- tcHsKindedContext ctxt
 379   ; fds' <- mappM (addLocM tc_fundep) fundeps
 380   ; sig_stuff <- tcClassSigs class_name sigs meths
 381   ; clas <- fixM (\ clas ->
 382                 let     -- This little knot is just so we can get
 383                         -- hold of the name of the class TyCon, which we
 384                         -- need to look up its recursiveness and variance
 385                     tycon_name = tyConName (classTyCon clas)
 386                     tc_isrec = calc_isrec tycon_name
 387                     tc_vrcs  = calc_vrcs  tycon_name
 388                 in
 389                 buildClass class_name tvs' ctxt' fds'
 390                            sig_stuff tc_isrec tc_vrcs)
 391   ; return (AClass clas) }
 392   where
 393     tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
 394                                 ; tvs2' <- mappM tcLookupTyVar tvs2 ;
 395                                 ; return (tvs1', tvs2') }
 396
 397
 398 tcTyClDecl1 calc_vrcs calc_isrec
 399   (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
 400   = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 []))
 401
 402 -----------------------------------
 403 tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType
 404           -> ConDecl Name -> TcM DataCon
 405
 406 tcConDecl new_or_data tycon tyvars ctxt
 407            (ConDecl name ex_tvs ex_ctxt details)
 408   = tcTyVarBndrs ex_tvs         $ \ ex_tvs' -> do
 409     { ex_ctxt' <- tcHsKindedContext ex_ctxt
 410     ; unbox_strict <- doptM Opt_UnboxStrictFields
 411     ; let
 412         tc_datacon field_lbls btys
 413           = do { let { ubtys = map unLoc btys }
 414                ; arg_tys <- mappM (tcHsKindedType . getBangType) ubtys
 415                ; buildDataCon (unLoc name)
 416                     (argStrictness unbox_strict tycon ubtys arg_tys)
 417                     (map unLoc field_lbls)
 418                     tyvars ctxt ex_tvs' ex_ctxt'
 419                     arg_tys tycon }
 420     ; case details of
 421         PrefixCon btys     -> tc_datacon [] btys
 422         InfixCon bty1 bty2 -> tc_datacon [] [bty1,bty2]
 423         RecCon fields      -> do { checkTc (null ex_tvs') (exRecConErr name)
 424                                  ; let { (field_names, btys) = unzip fields }
 425                                  ; tc_datacon field_names btys } }
 426
 427 argStrictness :: Bool           -- True <=> -funbox-strict_fields
 428               -> TyCon -> [BangType Name]
 429               -> [TcType] -> [StrictnessMark]
 430 argStrictness unbox_strict tycon btys arg_tys
 431  = zipWith (chooseBoxingStrategy unbox_strict tycon)
 432            arg_tys
 433            (map getBangStrictness btys ++ repeat HsNoBang)
 434
 435 -- We attempt to unbox/unpack a strict field when either:
 436 --   (i)  The field is marked '!!', or
 437 --   (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
 438
 439 chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark
 440 chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
 441   = case bang of
 442         HsNoBang                                    -> NotMarkedStrict
 443         HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed
 444         HsUnbox  | can_unbox                        -> MarkedUnboxed
 445         other                                       -> MarkedStrict
 446   where
 447     can_unbox = case splitTyConApp_maybe arg_ty of
 448                    Nothing             -> False
 449                    Just (arg_tycon, _) -> not (isRecursiveTyCon tycon) &&
 450                                           isProductTyCon arg_tycon
 451 \end{code}
 452
 453 %************************************************************************
 454 %*                                                                      *
 455 \subsection{Dependency analysis}
 456 %*                                                                      *
 457 %************************************************************************
 458
 459 Validity checking is done once the mutually-recursive knot has been
 460 tied, so we can look at things freely.
 461
 462 \begin{code}
 463 checkCycleErrs :: [LTyClDecl Name] -> TcM ()
 464 checkCycleErrs tyclss
 465   | null cls_cycles
 466   = return ()
 467   | otherwise
 468   = do  { mappM_ recClsErr cls_cycles
 469         ; failM }       -- Give up now, because later checkValidTyCl
 470                         -- will loop if the synonym is recursive
 471   where
 472     cls_cycles = calcClassCycles tyclss
 473
 474 checkValidTyCl :: TyClDecl Name -> TcM ()
 475 -- We do the validity check over declarations, rather than TyThings
 476 -- only so that we can add a nice context with tcAddDeclCtxt
 477 checkValidTyCl decl
 478   = tcAddDeclCtxt decl $
 479     do  { thing <- tcLookupLocatedGlobal (tcdLName decl)
 480         ; traceTc (text "Validity of" <+> ppr thing)
 481         ; case thing of
 482             ATyCon tc -> checkValidTyCon tc
 483             AClass cl -> checkValidClass cl
 484         ; traceTc (text "Done validity of" <+> ppr thing)
 485         }
 486
 487 -------------------------
 488 checkValidTyCon :: TyCon -> TcM ()
 489 checkValidTyCon tc
 490   | isSynTyCon tc
 491   = checkValidType syn_ctxt syn_rhs
 492   | otherwise
 493   =     -- Check the context on the data decl
 494     checkValidTheta (DataTyCtxt name) (tyConTheta tc)   `thenM_`
 495
 496         -- Check arg types of data constructors
 497     mappM_ checkValidDataCon data_cons                  `thenM_`
 498
 499         -- Check that fields with the same name share a type
 500     mappM_ check_fields groups
 501
 502   where
 503     syn_ctxt     = TySynCtxt name
 504     name         = tyConName tc
 505     (_, syn_rhs) = getSynTyConDefn tc
 506     data_cons    = tyConDataCons tc
 507
 508     fields = [field | con <- data_cons, field <- dataConFieldLabels con]
 509     groups = equivClasses cmp_name fields
 510     cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2
 511
 512     check_fields fields@(first_field_label : other_fields)
 513         -- These fields all have the same name, but are from
 514         -- different constructors in the data type
 515         =       -- Check that all the fields in the group have the same type
 516                 -- NB: this check assumes that all the constructors of a given
 517                 -- data type use the same type variables
 518           checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name)
 519         where
 520             field_ty   = fieldLabelType first_field_label
 521             field_name = fieldLabelName first_field_label
 522             other_tys  = map fieldLabelType other_fields
 523
 524 -------------------------------
 525 checkValidDataCon :: DataCon -> TcM ()
 526 checkValidDataCon con
 527   = addErrCtxt (dataConCtxt con) (
 528       checkValidType ctxt (idType (dataConWrapId con))  `thenM_`
 529                 -- This checks the argument types and
 530                 -- ambiguity of the existential context (if any)
 531       checkFreeness ex_tvs ex_theta)
 532   where
 533     ctxt = ConArgCtxt (dataConName con)
 534     (_, _, ex_tvs, ex_theta, _, _) = dataConSig con
 535
 536
 537 -------------------------------
 538 checkValidClass :: Class -> TcM ()
 539 checkValidClass cls
 540   = do  {       -- CHECK ARITY 1 FOR HASKELL 1.4
 541           gla_exts <- doptM Opt_GlasgowExts
 542
 543         -- Check that the class is unary, unless GlaExs
 544         ; checkTc (notNull tyvars) (nullaryClassErr cls)
 545         ; checkTc (gla_exts || unary) (classArityErr cls)
 546
 547         -- Check the super-classes
 548         ; checkValidTheta (ClassSCCtxt (className cls)) theta
 549
 550         -- Check the class operations
 551         ; mappM_ check_op op_stuff
 552
 553         -- Check that if the class has generic methods, then the
 554         -- class has only one parameter.  We can't do generic
 555         -- multi-parameter type classes!
 556         ; checkTc (unary || no_generics) (genericMultiParamErr cls)
 557         }
 558   where
 559     (tyvars, theta, _, op_stuff) = classBigSig cls
 560     unary       = isSingleton tyvars
 561     no_generics = null [() | (_, GenDefMeth) <- op_stuff]
 562
 563     check_op (sel_id, dm)
 564       = addErrCtxt (classOpCtxt sel_id tau) $ do
 565         { checkValidTheta SigmaCtxt (tail theta)
 566                 -- The 'tail' removes the initial (C a) from the
 567                 -- class itself, leaving just the method type
 568
 569         ; checkValidType (FunSigCtxt op_name) tau
 570
 571                 -- Check that the type mentions at least one of
 572                 -- the class type variables
 573         ; checkTc (any (`elemVarSet` tyVarsOfType tau) tyvars)
 574                   (noClassTyVarErr cls sel_id)
 575
 576                 -- Check that for a generic method, the type of
 577                 -- the method is sufficiently simple
 578         ; checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
 579                   (badGenericMethodType op_name op_ty)
 580         }
 581         where
 582           op_name = idName sel_id
 583           op_ty   = idType sel_id
 584           (_,theta,tau) = tcSplitSigmaTy op_ty
 585
 586
 587
 588 ---------------------------------------------------------------------
 589 fieldTypeMisMatch field_name
 590   = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)]
 591
 592 dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"),
 593                        nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)]
 594   where
 595     (_, _, ex_tvs, ex_theta, arg_tys, _) = dataConSig con
 596     ex_part | null ex_tvs = empty
 597             | otherwise   = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot
 598         -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote
 599         --      data T a = Eq a => T a a
 600         -- So we make sure to print it
 601
 602     fields = dataConFieldLabels con
 603     arg_part | null fields = sep (map pprParendType arg_tys)
 604              | otherwise   = braces (sep (punctuate comma
 605                              [ ppr n <+> dcolon <+> ppr ty
 606                              | (n,ty) <- fields `zip` arg_tys]))
 607
 608 classOpCtxt sel_id tau = sep [ptext SLIT("When checking the class method:"),
 609                               nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
 610
 611 nullaryClassErr cls
 612   = ptext SLIT("No parameters for class")  <+> quotes (ppr cls)
 613
 614 classArityErr cls
 615   = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
 616           parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
 617
 618 noClassTyVarErr clas op
 619   = sep [ptext SLIT("The class method") <+> quotes (ppr op),
 620          ptext SLIT("mentions none of the type variables of the class") <+>
 621                 ppr clas <+> hsep (map ppr (classTyVars clas))]
 622
 623 genericMultiParamErr clas
 624   = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+>
 625     ptext SLIT("cannot have generic methods")
 626
 627 badGenericMethodType op op_ty
 628   = hang (ptext SLIT("Generic method type is too complex"))
 629        4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
 630                 ptext SLIT("You can only use type variables, arrows, and tuples")])
 631
 632 recSynErr syn_decls
 633   = addSrcSpan (getLoc (head syn_decls)) $
 634     addErr (sep [ptext SLIT("Cycle in type synonym declarations:"),
 635                  nest 2 (vcat (map ppr_decl syn_decls))])
 636   where
 637     ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
 638
 639 recClsErr cls_decls
 640   = addSrcSpan (getLoc (head cls_decls)) $
 641     addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"),
 642                  nest 2 (vcat (map ppr_decl cls_decls))])
 643   where
 644     ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] })
 645
 646 exRecConErr name
 647   = ptext SLIT("Can't combine named fields with locally-quantified type variables")
 648     $$
 649     (ptext SLIT("In the declaration of data constructor") <+> ppr name)
 650 \end{code}