ghc/compiler/rename/RnTypes.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnSource]{Main pass of renamer}
   5
   6 \begin{code}
   7 module RnTypes ( rnHsType, rnLHsType, rnLHsTypes, rnContext,
   8                  rnHsSigType, rnHsTypeFVs,
   9                  rnLPat, rnPat, rnPatsAndThen,          -- Here because it's not part
  10                  rnLit, rnOverLit,                      -- of any mutual recursion
  11                  precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize
  12   ) where
  13
  14 import CmdLineOpts      ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) )
  15
  16 import HsSyn
  17 import RdrHsSyn         ( extractHsRhoRdrTyVars )
  18 import RnHsSyn          ( extractHsTyNames, parrTyCon_name, tupleTyCon_name,
  19                           listTyCon_name
  20                         )
  21 import RnEnv            ( lookupOccRn, lookupBndrRn, lookupSyntaxName,
  22                           lookupLocatedOccRn, lookupLocatedBndrRn,
  23                           lookupLocatedGlobalOccRn, bindTyVarsRn, lookupFixityRn,
  24                           mapFvRn, warnUnusedMatches,
  25                           newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV )
  26 import TcRnMonad
  27 import RdrName          ( RdrName, elemLocalRdrEnv )
  28 import PrelNames        ( eqClassName, integralClassName,
  29                           negateName, minusName, lengthPName, indexPName,
  30                           plusIntegerName, fromIntegerName, timesIntegerName,
  31                           ratioDataConName, fromRationalName )
  32 import Constants        ( mAX_TUPLE_SIZE )
  33 import Name             ( Name )
  34 import SrcLoc           ( Located(..), unLoc )
  35 import NameSet
  36
  37 import Literal          ( inIntRange, inCharRange )
  38 import BasicTypes       ( compareFixity )
  39 import ListSetOps       ( removeDups )
  40 import Outputable
  41 import Monad            ( when )
  42
  43 #include "HsVersions.h"
  44 \end{code}
  45
  46 These type renamers are in a separate module, rather than in (say) RnSource,
  47 to break several loop.
  48
  49 %*********************************************************
  50 %*                                                      *
  51 \subsection{Renaming types}
  52 %*                                                      *
  53 %*********************************************************
  54
  55 \begin{code}
  56 rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
  57 rnHsTypeFVs doc_str ty
  58   = rnLHsType doc_str ty        `thenM` \ ty' ->
  59     returnM (ty', extractHsTyNames ty')
  60
  61 rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
  62         -- rnHsSigType is used for source-language type signatures,
  63         -- which use *implicit* universal quantification.
  64 rnHsSigType doc_str ty
  65   = rnLHsType (text "In the type signature for" <+> doc_str) ty
  66 \end{code}
  67
  68 rnHsType is here because we call it from loadInstDecl, and I didn't
  69 want a gratuitous knot.
  70
  71 \begin{code}
  72 rnLHsType  :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
  73 rnLHsType doc = wrapLocM (rnHsType doc)
  74
  75 rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)
  76
  77 rnHsType doc (HsForAllTy Implicit _ ctxt ty)
  78         -- Implicit quantifiction in source code (no kinds on tyvars)
  79         -- Given the signature  C => T  we universally quantify
  80         -- over FV(T) \ {in-scope-tyvars}
  81   = getLocalRdrEnv              `thenM` \ name_env ->
  82     let
  83         mentioned = extractHsRhoRdrTyVars ctxt ty
  84
  85         -- Don't quantify over type variables that are in scope;
  86         -- when GlasgowExts is off, there usually won't be any, except for
  87         -- class signatures:
  88         --      class C a where { op :: a -> a }
  89         forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
  90         tyvar_bndrs = [ L loc (UserTyVar v) | (L loc v) <- forall_tyvars ]
  91     in
  92     rnForAll doc Implicit tyvar_bndrs ctxt ty
  93
  94 rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau)
  95         -- Explicit quantification.
  96         -- Check that the forall'd tyvars are actually
  97         -- mentioned in the type, and produce a warning if not
  98   = let
  99         mentioned          = map unLoc (extractHsRhoRdrTyVars ctxt tau)
 100         forall_tyvar_names = hsLTyVarLocNames forall_tyvars
 101
 102         -- Explicitly quantified but not mentioned in ctxt or tau
 103         warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names
 104     in
 105     mappM_ (forAllWarn doc tau) warn_guys       `thenM_`
 106     rnForAll doc Explicit forall_tyvars ctxt tau
 107
 108 rnHsType doc (HsTyVar tyvar)
 109   = lookupOccRn tyvar           `thenM` \ tyvar' ->
 110     returnM (HsTyVar tyvar')
 111
 112 rnHsType doc (HsOpTy ty1 (L loc op) ty2)
 113   = setSrcSpan loc (
 114       lookupOccRn op                    `thenM` \ op' ->
 115       lookupTyFixityRn (L loc op')      `thenM` \ fix ->
 116       rnLHsType doc ty1                 `thenM` \ ty1' ->
 117       rnLHsType doc ty2                 `thenM` \ ty2' ->
 118       mkHsOpTyRn (L loc op') fix ty1' ty2'
 119    )
 120
 121 rnHsType doc (HsParTy ty)
 122   = rnLHsType doc ty            `thenM` \ ty' ->
 123     returnM (HsParTy ty')
 124
 125 rnHsType doc (HsBangTy b ty)
 126   = rnLHsType doc ty            `thenM` \ ty' ->
 127     returnM (HsBangTy b ty')
 128
 129 rnHsType doc (HsNumTy i)
 130   | i == 1    = returnM (HsNumTy i)
 131   | otherwise = addErr err_msg  `thenM_`  returnM (HsNumTy i)
 132   where
 133     err_msg = ptext SLIT("Only unit numeric type pattern is valid")
 134
 135
 136 rnHsType doc (HsFunTy ty1 ty2)
 137   = rnLHsType doc ty1   `thenM` \ ty1' ->
 138         -- Might find a for-all as the arg of a function type
 139     rnLHsType doc ty2   `thenM` \ ty2' ->
 140         -- Or as the result.  This happens when reading Prelude.hi
 141         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 142     returnM (HsFunTy ty1' ty2')
 143
 144 rnHsType doc (HsListTy ty)
 145   = rnLHsType doc ty                            `thenM` \ ty' ->
 146     returnM (HsListTy ty')
 147
 148 rnHsType doc (HsKindSig ty k)
 149   = rnLHsType doc ty                            `thenM` \ ty' ->
 150     returnM (HsKindSig ty' k)
 151
 152 rnHsType doc (HsPArrTy ty)
 153   = rnLHsType doc ty                            `thenM` \ ty' ->
 154     returnM (HsPArrTy ty')
 155
 156 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 157 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 158 rnHsType doc (HsTupleTy tup_con tys)
 159   = mappM (rnLHsType doc) tys           `thenM` \ tys' ->
 160     returnM (HsTupleTy tup_con tys')
 161
 162 rnHsType doc (HsAppTy ty1 ty2)
 163   = rnLHsType doc ty1           `thenM` \ ty1' ->
 164     rnLHsType doc ty2           `thenM` \ ty2' ->
 165     returnM (HsAppTy ty1' ty2')
 166
 167 rnHsType doc (HsPredTy pred)
 168   = rnPred doc pred     `thenM` \ pred' ->
 169     returnM (HsPredTy pred')
 170
 171 rnLHsTypes doc tys = mappM (rnLHsType doc) tys
 172 \end{code}
 173
 174
 175 \begin{code}
 176 rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
 177          -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
 178
 179 rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty
 180         -- One reason for this case is that a type like Int#
 181         -- starts off as (HsForAllTy Nothing [] Int), in case
 182         -- there is some quantification.  Now that we have quantified
 183         -- and discovered there are no type variables, it's nicer to turn
 184         -- it into plain Int.  If it were Int# instead of Int, we'd actually
 185         -- get an error, because the body of a genuine for-all is
 186         -- of kind *.
 187
 188 rnForAll doc exp forall_tyvars ctxt ty
 189   = bindTyVarsRn doc forall_tyvars      $ \ new_tyvars ->
 190     rnContext doc ctxt                  `thenM` \ new_ctxt ->
 191     rnLHsType doc ty                    `thenM` \ new_ty ->
 192     returnM (HsForAllTy exp new_tyvars new_ctxt new_ty)
 193         -- Retain the same implicit/explicit flag as before
 194         -- so that we can later print it correctly
 195 \end{code}
 196
 197
 198 %*********************************************************
 199 %*                                                      *
 200 \subsection{Fixities}
 201 %*                                                      *
 202 %*********************************************************
 203
 204 Infix types are read in a *right-associative* way, so that
 205         a `op` b `op` c
 206 is always read in as
 207         a `op` (b `op` c)
 208
 209 mkHsOpTyRn rearranges where necessary.  The two arguments
 210 have already been renamed and rearranged.  It's made rather tiresome
 211 by the presence of ->
 212
 213 \begin{code}
 214 lookupTyFixityRn (L loc n)
 215   = doptM Opt_GlasgowExts                       `thenM` \ glaExts ->
 216     when (not glaExts)
 217         (setSrcSpan loc $ addWarn (infixTyConWarn n))   `thenM_`
 218     lookupFixityRn n
 219
 220 -- Building (ty1 `op1` (ty21 `op2` ty22))
 221 mkHsOpTyRn :: Located Name -> Fixity
 222            -> LHsType Name -> LHsType Name
 223            -> RnM (HsType Name)
 224
 225 mkHsOpTyRn op1 fix1 ty1 ty2@(L loc (HsOpTy ty21 op2 ty22))
 226   = lookupTyFixityRn op2        `thenM` \ fix2 ->
 227     let
 228         (nofix_error, associate_right) = compareFixity fix1 fix2
 229     in
 230     if nofix_error then
 231         addErr (precParseErr (quotes (ppr op1),fix1)
 232                                (quotes (ppr op2),fix2)) `thenM_`
 233         returnM (HsOpTy ty1 op1 ty2)
 234     else
 235     if not associate_right then
 236         -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
 237         mkHsOpTyRn op1 fix1 ty1 ty21            `thenM` \ new_ty ->
 238         returnM (HsOpTy (L loc new_ty) op2 ty22)  -- XXX loc is wrong
 239     else
 240     returnM (HsOpTy ty1 op1 ty2)
 241
 242 mkHsOpTyRn op fix ty1 ty2                       -- Default case, no rearrangment
 243   = returnM (HsOpTy ty1 op ty2)
 244 \end{code}
 245
 246 %*********************************************************
 247 %*                                                      *
 248 \subsection{Contexts and predicates}
 249 %*                                                      *
 250 %*********************************************************
 251
 252 \begin{code}
 253 rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
 254 rnContext doc = wrapLocM (rnContext' doc)
 255
 256 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
 257 rnContext' doc ctxt = mappM (rnLPred doc) ctxt
 258
 259 rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
 260 rnLPred doc  = wrapLocM (rnPred doc)
 261
 262 rnPred doc (HsClassP clas tys)
 263   = lookupOccRn clas            `thenM` \ clas_name ->
 264     rnLHsTypes doc tys          `thenM` \ tys' ->
 265     returnM (HsClassP clas_name tys')
 266
 267 rnPred doc (HsIParam n ty)
 268   = newIPNameRn n               `thenM` \ name ->
 269     rnLHsType doc ty            `thenM` \ ty' ->
 270     returnM (HsIParam name ty')
 271 \end{code}
 272
 273
 274 *********************************************************
 275 *                                                       *
 276 \subsection{Patterns}
 277 *                                                       *
 278 *********************************************************
 279
 280 \begin{code}
 281 rnPatsAndThen :: HsMatchContext Name
 282               -> Bool
 283               -> [LPat RdrName]
 284               -> ([LPat Name] -> RnM (a, FreeVars))
 285               -> RnM (a, FreeVars)
 286 -- Bring into scope all the binders and type variables
 287 -- bound by the patterns; then rename the patterns; then
 288 -- do the thing inside.
 289 --
 290 -- Note that we do a single bindLocalsRn for all the
 291 -- matches together, so that we spot the repeated variable in
 292 --      f x x = 1
 293
 294 rnPatsAndThen ctxt repUnused pats thing_inside
 295   = bindPatSigTyVarsFV pat_sig_tys      $
 296     bindLocatedLocalsFV doc_pat bndrs   $ \ new_bndrs ->
 297     rnLPats pats                        `thenM` \ (pats', pat_fvs) ->
 298     thing_inside pats'                  `thenM` \ (res, res_fvs) ->
 299
 300     let
 301         unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs
 302     in
 303     (if repUnused
 304      then warnUnusedMatches unused_binders
 305      else returnM ())                  `thenM_`
 306     returnM (res, res_fvs `plusFV` pat_fvs)
 307   where
 308     pat_sig_tys = collectSigTysFromPats pats
 309     bndrs       = collectLocatedPatsBinders pats
 310     doc_pat     = ptext SLIT("In") <+> pprMatchContext ctxt
 311
 312 rnLPats :: [LPat RdrName] -> RnM ([LPat Name], FreeVars)
 313 rnLPats ps = mapFvRn rnLPat ps
 314
 315 rnLPat :: LPat RdrName -> RnM (LPat Name, FreeVars)
 316 rnLPat = wrapLocFstM rnPat
 317
 318 -- -----------------------------------------------------------------------------
 319 -- rnPat
 320
 321 rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars)
 322
 323 rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs)
 324
 325 rnPat (VarPat name)
 326   = lookupBndrRn  name                  `thenM` \ vname ->
 327     returnM (VarPat vname, emptyFVs)
 328
 329 rnPat (SigPatIn pat ty)
 330   = doptM Opt_GlasgowExts `thenM` \ glaExts ->
 331
 332     if glaExts
 333     then rnLPat pat             `thenM` \ (pat', fvs1) ->
 334          rnHsTypeFVs doc ty     `thenM` \ (ty',  fvs2) ->
 335          returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
 336
 337     else addErr (patSigErr ty)  `thenM_`
 338          rnPat (unLoc pat) -- XXX shouldn't throw away the loc
 339   where
 340     doc = text "In a pattern type-signature"
 341
 342 rnPat (LitPat lit)
 343   = rnLit lit   `thenM_`
 344     returnM (LitPat lit, emptyFVs)
 345
 346 rnPat (NPatIn lit mb_neg)
 347   = rnOverLit lit                       `thenM` \ (lit', fvs1) ->
 348     (case mb_neg of
 349         Nothing -> returnM (Nothing, emptyFVs)
 350         Just _  -> lookupSyntaxName negateName  `thenM` \ (neg, fvs) ->
 351                    returnM (Just neg, fvs)
 352     )                                   `thenM` \ (mb_neg', fvs2) ->
 353     returnM (NPatIn lit' mb_neg',
 354               fvs1 `plusFV` fvs2 `addOneFV` eqClassName)
 355         -- Needed to find equality on pattern
 356
 357 rnPat (NPlusKPatIn name lit _)
 358   = rnOverLit lit                       `thenM` \ (lit', fvs1) ->
 359     lookupLocatedBndrRn name            `thenM` \ name' ->
 360     lookupSyntaxName minusName          `thenM` \ (minus, fvs2) ->
 361     returnM (NPlusKPatIn name' lit' minus,
 362               fvs1 `plusFV` fvs2 `addOneFV` integralClassName)
 363         -- The Report says that n+k patterns must be in Integral
 364
 365 rnPat (LazyPat pat)
 366   = rnLPat pat          `thenM` \ (pat', fvs) ->
 367     returnM (LazyPat pat', fvs)
 368
 369 rnPat (AsPat name pat)
 370   = rnLPat pat                  `thenM` \ (pat', fvs) ->
 371     lookupLocatedBndrRn name    `thenM` \ vname ->
 372     returnM (AsPat vname pat', fvs)
 373
 374 rnPat (ConPatIn con stuff) = rnConPat con stuff
 375
 376
 377 rnPat (ParPat pat)
 378   = rnLPat pat          `thenM` \ (pat', fvs) ->
 379     returnM (ParPat pat', fvs)
 380
 381 rnPat (ListPat pats _)
 382   = rnLPats pats                        `thenM` \ (patslist, fvs) ->
 383     returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name)
 384
 385 rnPat (PArrPat pats _)
 386   = rnLPats pats                        `thenM` \ (patslist, fvs) ->
 387     returnM (PArrPat patslist placeHolderType,
 388               fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
 389   where
 390     implicit_fvs = mkFVs [lengthPName, indexPName]
 391
 392 rnPat (TuplePat pats boxed)
 393   = checkTupSize tup_size       `thenM_`
 394     rnLPats pats                        `thenM` \ (patslist, fvs) ->
 395     returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name)
 396   where
 397     tup_size   = length pats
 398     tycon_name = tupleTyCon_name boxed tup_size
 399
 400 rnPat (TypePat name) =
 401     rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->
 402     returnM (TypePat name', fvs)
 403
 404 -- -----------------------------------------------------------------------------
 405 -- rnConPat
 406
 407 rnConPat con (PrefixCon pats)
 408   = lookupLocatedOccRn con      `thenM` \ con' ->
 409     rnLPats pats                `thenM` \ (pats', fvs) ->
 410     returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con')
 411
 412 rnConPat con (RecCon rpats)
 413   = lookupLocatedOccRn con      `thenM` \ con' ->
 414     rnRpats rpats               `thenM` \ (rpats', fvs) ->
 415     returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con')
 416
 417 rnConPat con (InfixCon pat1 pat2)
 418   = lookupLocatedOccRn con                      `thenM` \ con' ->
 419     rnLPat pat1                                 `thenM` \ (pat1', fvs1) ->
 420     rnLPat pat2                                 `thenM` \ (pat2', fvs2) ->
 421     lookupFixityRn (unLoc con')                 `thenM` \ fixity ->
 422     mkConOpPatRn con' fixity pat1' pat2'        `thenM` \ pat' ->
 423     returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con')
 424
 425 -- -----------------------------------------------------------------------------
 426 -- rnRpats
 427
 428 rnRpats :: [(Located RdrName, LPat RdrName)]
 429         -> RnM ([(Located Name, LPat Name)], FreeVars)
 430 rnRpats rpats
 431   = mappM_ field_dup_err dup_fields     `thenM_`
 432     mapFvRn rn_rpat rpats               `thenM` \ (rpats', fvs) ->
 433     returnM (rpats', fvs)
 434   where
 435     (_, dup_fields) = removeDups compare [ unLoc f | (f,_) <- rpats ]
 436
 437     field_dup_err dups = addErr (dupFieldErr "pattern" dups)
 438
 439     rn_rpat (field, pat)
 440       = lookupLocatedGlobalOccRn field  `thenM` \ fieldname ->
 441         rnLPat pat                      `thenM` \ (pat', fvs) ->
 442         returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname)
 443
 444 -- -----------------------------------------------------------------------------
 445 -- mkConOpPatRn
 446
 447 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
 448              -> RnM (Pat Name)
 449
 450 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
 451   = lookupFixityRn (unLoc op1)  `thenM` \ fix1 ->
 452     let
 453         (nofix_error, associate_right) = compareFixity fix1 fix2
 454     in
 455     if nofix_error then
 456         addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))       `thenM_`
 457         returnM (ConPatIn op2 (InfixCon p1 p2))
 458     else
 459     if associate_right then
 460         mkConOpPatRn op2 fix2 p12 p2            `thenM` \ new_p ->
 461         returnM (ConPatIn op1 (InfixCon p11 (L loc new_p)))  -- XXX loc right?
 462     else
 463     returnM (ConPatIn op2 (InfixCon p1 p2))
 464
 465 mkConOpPatRn op fix p1 p2                       -- Default case, no rearrangment
 466   = ASSERT( not_op_pat (unLoc p2) )
 467     returnM (ConPatIn op (InfixCon p1 p2))
 468
 469 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
 470 not_op_pat other                       = True
 471 \end{code}
 472
 473
 474 %************************************************************************
 475 %*                                                                      *
 476 \subsubsection{Literals}
 477 %*                                                                      *
 478 %************************************************************************
 479
 480 When literals occur we have to make sure
 481 that the types and classes they involve
 482 are made available.
 483
 484 \begin{code}
 485 rnLit :: HsLit -> RnM ()
 486 rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
 487 rnLit other      = returnM ()
 488
 489 rnOverLit (HsIntegral i _)
 490   = lookupSyntaxName fromIntegerName    `thenM` \ (from_integer_name, fvs) ->
 491     if inIntRange i then
 492         returnM (HsIntegral i from_integer_name, fvs)
 493     else let
 494         extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
 495         -- Big integer literals are built, using + and *,
 496         -- out of small integers (DsUtils.mkIntegerLit)
 497         -- [NB: plusInteger, timesInteger aren't rebindable...
 498         --      they are used to construct the argument to fromInteger,
 499         --      which is the rebindable one.]
 500     in
 501     returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs)
 502
 503 rnOverLit (HsFractional i _)
 504   = lookupSyntaxName fromRationalName           `thenM` \ (from_rat_name, fvs) ->
 505     let
 506         extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
 507         -- We have to make sure that the Ratio type is imported with
 508         -- its constructor, because literals of type Ratio t are
 509         -- built with that constructor.
 510         -- The Rational type is needed too, but that will come in
 511         -- as part of the type for fromRational.
 512         -- The plus/times integer operations may be needed to construct the numerator
 513         -- and denominator (see DsUtils.mkIntegerLit)
 514     in
 515     returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
 516 \end{code}
 517
 518
 519
 520 %*********************************************************
 521 %*                                                      *
 522 \subsection{Errors}
 523 %*                                                      *
 524 %*********************************************************
 525
 526 \begin{code}
 527 checkTupSize :: Int -> RnM ()
 528 checkTupSize tup_size
 529   | tup_size <= mAX_TUPLE_SIZE
 530   = returnM ()
 531   | otherwise
 532   = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"),
 533                  nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)),
 534                  nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))])
 535
 536 forAllWarn doc ty (L loc tyvar)
 537   = ifOptM Opt_WarnUnusedMatches        $
 538     setSrcSpan loc $
 539     addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 540                    nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 541                    $$
 542                    doc
 543                 )
 544
 545 bogusCharError c
 546   = ptext SLIT("character literal out of range: '\\") <> char c  <> char '\''
 547
 548 precParseErr op1 op2
 549   = hang (ptext SLIT("precedence parsing error"))
 550       4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
 551                ppr_opfix op2,
 552                ptext SLIT("in the same infix expression")])
 553
 554 sectionPrecErr op arg_op section
 555  = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
 556          nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
 557          nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
 558
 559 infixTyConWarn op
 560   = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op),
 561           ftext FSLIT("Use -fglasgow-exts to avoid this warning"))
 562
 563 patSigErr ty
 564   =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
 565         $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
 566
 567 dupFieldErr str dup
 568   = hsep [ptext SLIT("duplicate field name"),
 569           quotes (ppr dup),
 570           ptext SLIT("in record"), text str]
 571
 572 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
 573 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
 574 \end{code}