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(..), pprUserTypeCtxt )
  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   = addErrCtxt (checkTypeCtxt syn_ctxt syn_rhs) $
 437     checkValidType syn_ctxt syn_rhs
 438   | otherwise
 439   =     -- Check the context on the data decl
 440     checkValidTheta (DataTyCtxt name) (tyConTheta tc)   `thenM_`
 441
 442         -- Check arg types of data constructors
 443     mappM_ checkValidDataCon data_cons                  `thenM_`
 444
 445         -- Check that fields with the same name share a type
 446     mappM_ check_fields groups
 447
 448   where
 449     syn_ctxt     = TySynCtxt name
 450     name         = tyConName tc
 451     (_, syn_rhs) = getSynTyConDefn tc
 452     data_cons    = tyConDataCons tc
 453
 454     fields = [field | con <- data_cons, field <- dataConFieldLabels con]
 455     groups = equivClasses cmp_name fields
 456     cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2
 457
 458     check_fields fields@(first_field_label : other_fields)
 459         -- These fields all have the same name, but are from
 460         -- different constructors in the data type
 461         =       -- Check that all the fields in the group have the same type
 462                 -- NB: this check assumes that all the constructors of a given
 463                 -- data type use the same type variables
 464           checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name)
 465         where
 466             field_ty   = fieldLabelType first_field_label
 467             field_name = fieldLabelName first_field_label
 468             other_tys  = map fieldLabelType other_fields
 469
 470 -------------------------------
 471 checkValidDataCon :: DataCon -> TcM ()
 472 checkValidDataCon con
 473   = addErrCtxt (dataConCtxt con) (
 474       checkValidType ctxt (idType (dataConWrapId con))  `thenM_`
 475                 -- This checks the argument types and
 476                 -- ambiguity of the existential context (if any)
 477       checkFreeness ex_tvs ex_theta)
 478   where
 479     ctxt = ConArgCtxt (dataConName con)
 480     (_, _, ex_tvs, ex_theta, _, _) = dataConSig con
 481
 482
 483 -------------------------------
 484 checkValidClass :: Class -> TcM ()
 485 checkValidClass cls
 486   = do  {       -- CHECK ARITY 1 FOR HASKELL 1.4
 487           gla_exts <- doptM Opt_GlasgowExts
 488
 489         -- Check that the class is unary, unless GlaExs
 490         ; checkTc (notNull tyvars) (nullaryClassErr cls)
 491         ; checkTc (gla_exts || unary) (classArityErr cls)
 492
 493         -- Check the super-classes
 494         ; checkValidTheta (ClassSCCtxt (className cls)) theta
 495
 496         -- Check the class operations
 497         ; mappM_ check_op op_stuff
 498
 499         -- Check that if the class has generic methods, then the
 500         -- class has only one parameter.  We can't do generic
 501         -- multi-parameter type classes!
 502         ; checkTc (unary || no_generics) (genericMultiParamErr cls)
 503         }
 504   where
 505     (tyvars, theta, _, op_stuff) = classBigSig cls
 506     unary       = isSingleton tyvars
 507     no_generics = null [() | (_, GenDefMeth) <- op_stuff]
 508
 509     check_op (sel_id, dm)
 510         = addErrCtxt (classOpCtxt sel_id) (
 511           checkValidTheta SigmaCtxt (tail theta)        `thenM_`
 512                 -- The 'tail' removes the initial (C a) from the
 513                 -- class itself, leaving just the method type
 514
 515           checkValidType (FunSigCtxt op_name) tau       `thenM_`
 516
 517                 -- Check that for a generic method, the type of
 518                 -- the method is sufficiently simple
 519           checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
 520                   (badGenericMethodType op_name op_ty)
 521         )
 522         where
 523           op_name = idName sel_id
 524           op_ty   = idType sel_id
 525           (_,theta,tau) = tcSplitSigmaTy op_ty
 526
 527
 528
 529 ---------------------------------------------------------------------
 530 fieldTypeMisMatch field_name
 531   = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)]
 532
 533 checkTypeCtxt ctxt ty
 534   = vcat [ptext SLIT("In the type:") <+> ppr_ty,
 535           ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ]
 536   where
 537         -- Hack alert.  If there are no tyvars, (ppr sigma_ty) will print
 538         -- something strange like {Eq k} -> k -> k, because there is no
 539         -- ForAll at the top of the type.  Since this is going to the user
 540         -- we want it to look like a proper Haskell type even then; hence the hack
 541         --
 542         -- This shows up in the complaint about
 543         --      case C a where
 544         --        op :: Eq a => a -> a
 545     ppr_ty | null forall_tvs = pprThetaArrow theta <+> ppr tau
 546            | otherwise       = ppr ty
 547
 548     (forall_tvs, theta, tau) = tcSplitSigmaTy ty
 549
 550 dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"),
 551                        nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)]
 552   where
 553     (_, _, ex_tvs, ex_theta, arg_tys, _) = dataConSig con
 554     ex_part | null ex_tvs = empty
 555             | otherwise   = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot
 556         -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote
 557         --      data T a = Eq a => T a a
 558         -- So we make sure to print it
 559
 560     fields = dataConFieldLabels con
 561     arg_part | null fields = sep (map pprParendType arg_tys)
 562              | otherwise   = braces (sep (punctuate comma
 563                              [ ppr n <+> dcolon <+> ppr ty
 564                              | (n,ty) <- fields `zip` arg_tys]))
 565
 566 classOpCtxt sel_id = sep [ptext SLIT("When checking the class method:"),
 567                           nest 2 (ppr sel_id <+> dcolon <+> ppr (idType sel_id))]
 568
 569 nullaryClassErr cls
 570   = ptext SLIT("No parameters for class")  <+> quotes (ppr cls)
 571
 572 classArityErr cls
 573   = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
 574           parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
 575
 576 genericMultiParamErr clas
 577   = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+>
 578     ptext SLIT("cannot have generic methods")
 579
 580 badGenericMethodType op op_ty
 581   = hang (ptext SLIT("Generic method type is too complex"))
 582        4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
 583                 ptext SLIT("You can only use type variables, arrows, and tuples")])
 584
 585 recSynErr tcs
 586   = addSrcLoc (getSrcLoc (head tcs)) $
 587     addErr (sep [ptext SLIT("Cycle in type synonym declarations:"),
 588                  nest 2 (vcat (map ppr_thing tcs))])
 589
 590 recClsErr clss
 591   = addSrcLoc (getSrcLoc (head clss)) $
 592     addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"),
 593                  nest 2 (vcat (map ppr_thing clss))])
 594
 595 ppr_thing :: Name -> SDoc
 596 ppr_thing n = ppr n <+> parens (ppr (getSrcLoc n))
 597
 598
 599 exRecConErr name
 600   = ptext SLIT("Can't combine named fields with locally-quantified type variables")
 601     $$
 602     (ptext SLIT("In the declaration of data constructor") <+> ppr name)
 603 \end{code}