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