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