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