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 (
   8         -- Type related stuff
   9         rnHsType, rnLHsType, rnLHsTypes, rnContext,
  10         rnHsSigType, rnHsTypeFVs,
  11
  12         -- Precence related stuff
  13         mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
  14         checkPrecMatch, checkSectionPrec
  15   ) where
  16
  17 import DynFlags
  18 import HsSyn
  19 import RdrHsSyn         ( extractHsRhoRdrTyVars )
  20 import RnHsSyn          ( extractHsTyNames )
  21 import RnHsDoc          ( rnLHsDoc )
  22 import RnEnv
  23 import TcRnMonad
  24 import RdrName
  25 import PrelNames
  26 import TypeRep          ( funTyConName )
  27 import Name
  28 import SrcLoc
  29 import NameSet
  30
  31 import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
  32                           Fixity(..), FixityDirection(..) )
  33 import Outputable
  34 import FastString
  35 import Control.Monad    ( unless )
  36
  37 #include "HsVersions.h"
  38 \end{code}
  39
  40 These type renamers are in a separate module, rather than in (say) RnSource,
  41 to break several loop.
  42
  43 %*********************************************************
  44 %*                                                      *
  45 \subsection{Renaming types}
  46 %*                                                      *
  47 %*********************************************************
  48
  49 \begin{code}
  50 rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
  51 rnHsTypeFVs doc_str ty  = do
  52     ty' <- rnLHsType doc_str ty
  53     return (ty', extractHsTyNames ty')
  54
  55 rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
  56         -- rnHsSigType is used for source-language type signatures,
  57         -- which use *implicit* universal quantification.
  58 rnHsSigType doc_str ty
  59   = rnLHsType (text "In the type signature for" <+> doc_str) ty
  60 \end{code}
  61
  62 rnHsType is here because we call it from loadInstDecl, and I didn't
  63 want a gratuitous knot.
  64
  65 \begin{code}
  66 rnLHsType  :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
  67 rnLHsType doc = wrapLocM (rnHsType doc)
  68
  69 rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)
  70
  71 rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do
  72         -- Implicit quantifiction in source code (no kinds on tyvars)
  73         -- Given the signature  C => T  we universally quantify
  74         -- over FV(T) \ {in-scope-tyvars}
  75     name_env <- getLocalRdrEnv
  76     let
  77         mentioned = extractHsRhoRdrTyVars ctxt ty
  78
  79         -- Don't quantify over type variables that are in scope;
  80         -- when GlasgowExts is off, there usually won't be any, except for
  81         -- class signatures:
  82         --      class C a where { op :: a -> a }
  83         forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
  84         tyvar_bndrs   = userHsTyVarBndrs forall_tyvars
  85
  86     rnForAll doc Implicit tyvar_bndrs ctxt ty
  87
  88 rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) = do
  89         -- Explicit quantification.
  90         -- Check that the forall'd tyvars are actually
  91         -- mentioned in the type, and produce a warning if not
  92     let
  93         mentioned          = map unLoc (extractHsRhoRdrTyVars ctxt tau)
  94         forall_tyvar_names = hsLTyVarLocNames forall_tyvars
  95
  96         -- Explicitly quantified but not mentioned in ctxt or tau
  97         warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names
  98
  99     mapM_ (forAllWarn doc tau) warn_guys
 100     rnForAll doc Explicit forall_tyvars ctxt tau
 101
 102 rnHsType _ (HsTyVar tyvar) = do
 103     tyvar' <- lookupOccRn tyvar
 104     return (HsTyVar tyvar')
 105
 106 -- If we see (forall a . ty), without foralls on, the forall will give
 107 -- a sensible error message, but we don't want to complain about the dot too
 108 -- Hence the jiggery pokery with ty1
 109 rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
 110   = setSrcSpan loc $
 111     do  { ops_ok <- doptM Opt_TypeOperators
 112         ; op' <- if ops_ok
 113                  then lookupOccRn op
 114                  else do { addErr (opTyErr op ty)
 115                          ; return (mkUnboundName op) }  -- Avoid double complaint
 116         ; let l_op' = L loc op'
 117         ; fix <- lookupTyFixityRn l_op'
 118         ; ty1' <- rnLHsType doc ty1
 119         ; ty2' <- rnLHsType doc ty2
 120         ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) op' fix ty1' ty2' }
 121
 122 rnHsType doc (HsParTy ty) = do
 123     ty' <- rnLHsType doc ty
 124     return (HsParTy ty')
 125
 126 rnHsType doc (HsBangTy b ty) = do
 127     ty' <- rnLHsType doc ty
 128     return (HsBangTy b ty')
 129
 130 rnHsType _ (HsNumTy i)
 131   | i == 1    = return (HsNumTy i)
 132   | otherwise = addErr err_msg >> return (HsNumTy i)
 133   where
 134     err_msg = ptext (sLit "Only unit numeric type pattern is valid")
 135
 136
 137 rnHsType doc (HsFunTy ty1 ty2) = do
 138     ty1' <- rnLHsType doc ty1
 139         -- Might find a for-all as the arg of a function type
 140     ty2' <- rnLHsType doc ty2
 141         -- Or as the result.  This happens when reading Prelude.hi
 142         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 143
 144         -- Check for fixity rearrangements
 145     mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
 146
 147 rnHsType doc (HsListTy ty) = do
 148     ty' <- rnLHsType doc ty
 149     return (HsListTy ty')
 150
 151 rnHsType doc (HsKindSig ty k) = do
 152     ty' <- rnLHsType doc ty
 153     return (HsKindSig ty' k)
 154
 155 rnHsType doc (HsPArrTy ty) = do
 156     ty' <- rnLHsType doc ty
 157     return (HsPArrTy ty')
 158
 159 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 160 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 161 rnHsType doc (HsTupleTy tup_con tys) = do
 162     tys' <- mapM (rnLHsType doc) tys
 163     return (HsTupleTy tup_con tys')
 164
 165 rnHsType doc (HsAppTy ty1 ty2) = do
 166     ty1' <- rnLHsType doc ty1
 167     ty2' <- rnLHsType doc ty2
 168     return (HsAppTy ty1' ty2')
 169
 170 rnHsType doc (HsPredTy pred) = do
 171     pred' <- rnPred doc pred
 172     return (HsPredTy pred')
 173
 174 rnHsType _ (HsSpliceTy _) =
 175     failWith (ptext (sLit "Type splices are not yet implemented"))
 176
 177 rnHsType doc (HsDocTy ty haddock_doc) = do
 178     ty' <- rnLHsType doc ty
 179     haddock_doc' <- rnLHsDoc haddock_doc
 180     return (HsDocTy ty' haddock_doc')
 181
 182 rnLHsTypes :: SDoc -> [LHsType RdrName]
 183            -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
 184 rnLHsTypes doc tys = mapM (rnLHsType doc) tys
 185 \end{code}
 186
 187
 188 \begin{code}
 189 rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
 190          -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
 191
 192 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
 193         -- One reason for this case is that a type like Int#
 194         -- starts off as (HsForAllTy Nothing [] Int), in case
 195         -- there is some quantification.  Now that we have quantified
 196         -- and discovered there are no type variables, it's nicer to turn
 197         -- it into plain Int.  If it were Int# instead of Int, we'd actually
 198         -- get an error, because the body of a genuine for-all is
 199         -- of kind *.
 200
 201 rnForAll doc exp forall_tyvars ctxt ty
 202   = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do
 203     new_ctxt <- rnContext doc ctxt
 204     new_ty <- rnLHsType doc ty
 205     return (HsForAllTy exp new_tyvars new_ctxt new_ty)
 206         -- Retain the same implicit/explicit flag as before
 207         -- so that we can later print it correctly
 208 \end{code}
 209
 210 %*********************************************************
 211 %*                                                      *
 212 \subsection{Contexts and predicates}
 213 %*                                                      *
 214 %*********************************************************
 215
 216 \begin{code}
 217 rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
 218 rnContext doc = wrapLocM (rnContext' doc)
 219
 220 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
 221 rnContext' doc ctxt = mapM (rnLPred doc) ctxt
 222
 223 rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
 224 rnLPred doc  = wrapLocM (rnPred doc)
 225
 226 rnPred :: SDoc -> HsPred RdrName
 227        -> IOEnv (Env TcGblEnv TcLclEnv) (HsPred Name)
 228 rnPred doc (HsClassP clas tys)
 229   = do { clas_name <- lookupOccRn clas
 230        ; tys' <- rnLHsTypes doc tys
 231        ; return (HsClassP clas_name tys')
 232        }
 233 rnPred doc (HsEqualP ty1 ty2)
 234   = do { ty1' <- rnLHsType doc ty1
 235        ; ty2' <- rnLHsType doc ty2
 236        ; return (HsEqualP ty1' ty2')
 237        }
 238 rnPred doc (HsIParam n ty)
 239   = do { name <- newIPNameRn n
 240        ; ty' <- rnLHsType doc ty
 241        ; return (HsIParam name ty')
 242        }
 243 \end{code}
 244
 245
 246 %************************************************************************
 247 %*                                                                      *
 248         Fixities and precedence parsing
 249 %*                                                                      *
 250 %************************************************************************
 251
 252 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 253 are assumed to be already correctly arranged.  It needs the fixities
 254 recorded in the OpApp nodes, because fixity info applies to the things
 255 the programmer actually wrote, so you can't find it out from the Name.
 256
 257 Furthermore, the second argument is guaranteed not to be another
 258 operator application.  Why? Because the parser parses all
 259 operator appications left-associatively, EXCEPT negation, which
 260 we need to handle specially.
 261 Infix types are read in a *right-associative* way, so that
 262         a `op` b `op` c
 263 is always read in as
 264         a `op` (b `op` c)
 265
 266 mkHsOpTyRn rearranges where necessary.  The two arguments
 267 have already been renamed and rearranged.  It's made rather tiresome
 268 by the presence of ->, which is a separate syntactic construct.
 269
 270 \begin{code}
 271 ---------------
 272 -- Building (ty1 `op1` (ty21 `op2` ty22))
 273 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
 274            -> Name -> Fixity -> LHsType Name -> LHsType Name
 275            -> RnM (HsType Name)
 276
 277 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
 278   = do  { fix2 <- lookupTyFixityRn op2
 279         ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
 280                       (\t1 t2 -> HsOpTy t1 op2 t2)
 281                       (unLoc op2) fix2 ty21 ty22 loc2 }
 282
 283 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
 284   = mk_hs_op_ty mk1 pp_op1 fix1 ty1
 285                 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
 286
 287 mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
 288   = return (mk1 ty1 ty2)
 289
 290 ---------------
 291 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
 292             -> Name -> Fixity -> LHsType Name
 293             -> (LHsType Name -> LHsType Name -> HsType Name)
 294             -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
 295             -> RnM (HsType Name)
 296 mk_hs_op_ty mk1 op1 fix1 ty1
 297             mk2 op2 fix2 ty21 ty22 loc2
 298   | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
 299                          ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
 300   | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
 301   | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
 302                            new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
 303                          ; return (mk2 (noLoc new_ty) ty22) }
 304   where
 305     (nofix_error, associate_right) = compareFixity fix1 fix2
 306
 307
 308 ---------------------------
 309 mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged
 310           -> LHsExpr Name -> Fixity             -- Operator and fixity
 311           -> LHsExpr Name                       -- Right operand (not an OpApp, but might
 312                                                 -- be a NegApp)
 313           -> RnM (HsExpr Name)
 314
 315 -- (e11 `op1` e12) `op2` e2
 316 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
 317   | nofix_error
 318   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
 319        return (OpApp e1 op2 fix2 e2)
 320
 321   | associate_right = do
 322     new_e <- mkOpAppRn e12 op2 fix2 e2
 323     return (OpApp e11 op1 fix1 (L loc' new_e))
 324   where
 325     loc'= combineLocs e12 e2
 326     (nofix_error, associate_right) = compareFixity fix1 fix2
 327
 328 ---------------------------
 329 --      (- neg_arg) `op` e2
 330 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
 331   | nofix_error
 332   = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
 333        return (OpApp e1 op2 fix2 e2)
 334
 335   | associate_right
 336   = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
 337        return (NegApp (L loc' new_e) neg_name)
 338   where
 339     loc' = combineLocs neg_arg e2
 340     (nofix_error, associate_right) = compareFixity negateFixity fix2
 341
 342 ---------------------------
 343 --      e1 `op` - neg_arg
 344 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
 345   | not associate_right                 -- We *want* right association
 346   = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
 347        return (OpApp e1 op1 fix1 e2)
 348   where
 349     (_, associate_right) = compareFixity fix1 negateFixity
 350
 351 ---------------------------
 352 --      Default case
 353 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 354   = ASSERT2( right_op_ok fix (unLoc e2),
 355              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
 356     )
 357     return (OpApp e1 op fix e2)
 358
 359 ----------------------------
 360 get_op :: LHsExpr Name -> Name
 361 get_op (L _ (HsVar n)) = n
 362 get_op other           = pprPanic "get_op" (ppr other)
 363
 364 -- Parser left-associates everything, but
 365 -- derived instances may have correctly-associated things to
 366 -- in the right operarand.  So we just check that the right operand is OK
 367 right_op_ok :: Fixity -> HsExpr Name -> Bool
 368 right_op_ok fix1 (OpApp _ _ fix2 _)
 369   = not error_please && associate_right
 370   where
 371     (error_please, associate_right) = compareFixity fix1 fix2
 372 right_op_ok _ _
 373   = True
 374
 375 -- Parser initially makes negation bind more tightly than any other operator
 376 -- And "deriving" code should respect this (use HsPar if not)
 377 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
 378 mkNegAppRn neg_arg neg_name
 379   = ASSERT( not_op_app (unLoc neg_arg) )
 380     return (NegApp neg_arg neg_name)
 381
 382 not_op_app :: HsExpr id -> Bool
 383 not_op_app (OpApp _ _ _ _) = False
 384 not_op_app _               = True
 385
 386 ---------------------------
 387 mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
 388           -> LHsExpr Name -> Fixity     -- Operator and fixity
 389           -> LHsCmdTop Name             -- Right operand (not an infix)
 390           -> RnM (HsCmd Name)
 391
 392 -- (e11 `op1` e12) `op2` e2
 393 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
 394         op2 fix2 a2
 395   | nofix_error
 396   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
 397        return (HsArrForm op2 (Just fix2) [a1, a2])
 398
 399   | associate_right
 400   = do new_c <- mkOpFormRn a12 op2 fix2 a2
 401        return (HsArrForm op1 (Just fix1)
 402                   [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
 403         -- TODO: locs are wrong
 404   where
 405     (nofix_error, associate_right) = compareFixity fix1 fix2
 406
 407 --      Default case
 408 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
 409   = return (HsArrForm op (Just fix) [arg1, arg2])
 410
 411
 412 --------------------------------------
 413 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
 414              -> RnM (Pat Name)
 415
 416 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
 417   = do  { fix1 <- lookupFixityRn (unLoc op1)
 418         ; let (nofix_error, associate_right) = compareFixity fix1 fix2
 419
 420         ; if nofix_error then do
 421                 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
 422                 ; return (ConPatIn op2 (InfixCon p1 p2)) }
 423
 424           else if associate_right then do
 425                 { new_p <- mkConOpPatRn op2 fix2 p12 p2
 426                 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
 427           else return (ConPatIn op2 (InfixCon p1 p2)) }
 428
 429 mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
 430   = ASSERT( not_op_pat (unLoc p2) )
 431     return (ConPatIn op (InfixCon p1 p2))
 432
 433 not_op_pat :: Pat Name -> Bool
 434 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
 435 not_op_pat _                           = True
 436
 437 --------------------------------------
 438 checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
 439         -- True indicates an infix lhs
 440         -- See comments with rnExpr (OpApp ...) about "deriving"
 441
 442 checkPrecMatch False _ _
 443   = return ()
 444 checkPrecMatch True op (MatchGroup ms _)
 445   = mapM_ check ms
 446   where
 447     check (L _ (Match (p1:p2:_) _ _))
 448       = do checkPrec op (unLoc p1) False
 449            checkPrec op (unLoc p2) True
 450
 451     check _ = return ()
 452         -- This can happen.  Consider
 453         --      a `op` True = ...
 454         --      op          = ...
 455         -- The infix flag comes from the first binding of the group
 456         -- but the second eqn has no args (an error, but not discovered
 457         -- until the type checker).  So we don't want to crash on the
 458         -- second eqn.
 459
 460 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
 461 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
 462     op_fix@(Fixity op_prec  op_dir) <- lookupFixityRn op
 463     op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
 464     let
 465         inf_ok = op1_prec > op_prec ||
 466                  (op1_prec == op_prec &&
 467                   (op1_dir == InfixR && op_dir == InfixR && right ||
 468                    op1_dir == InfixL && op_dir == InfixL && not right))
 469
 470         info  = (op,        op_fix)
 471         info1 = (unLoc op1, op1_fix)
 472         (infol, infor) = if right then (info, info1) else (info1, info)
 473     unless inf_ok (precParseErr infol infor)
 474
 475 checkPrec _ _ _
 476   = return ()
 477
 478 -- Check precedence of (arg op) or (op arg) respectively
 479 -- If arg is itself an operator application, then either
 480 --   (a) its precedence must be higher than that of op
 481 --   (b) its precedency & associativity must be the same as that of op
 482 checkSectionPrec :: FixityDirection -> HsExpr RdrName
 483         -> LHsExpr Name -> LHsExpr Name -> RnM ()
 484 checkSectionPrec direction section op arg
 485   = case unLoc arg of
 486         OpApp _ op fix _ -> go_for_it (get_op op) fix
 487         NegApp _ _       -> go_for_it negateName  negateFixity
 488         _                -> return ()
 489   where
 490     op_name = get_op op
 491     go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
 492           op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
 493           unless (op_prec < arg_prec
 494                   || (op_prec == arg_prec && direction == assoc))
 495                  (sectionPrecErr (op_name, op_fix)
 496                                  (arg_op, arg_fix) section)
 497 \end{code}
 498
 499 Precedence-related error messages
 500
 501 \begin{code}
 502 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
 503 precParseErr op1@(n1,_) op2@(n2,_)
 504   | isUnboundName n1 || isUnboundName n2
 505   = return ()     -- Avoid error cascade
 506   | otherwise
 507   = addErr $ hang (ptext (sLit "Precedence parsing error"))
 508       4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
 509                ppr_opfix op2,
 510                ptext (sLit "in the same infix expression")])
 511
 512 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
 513 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
 514   | isUnboundName n1 || isUnboundName n2
 515   = return ()     -- Avoid error cascade
 516   | otherwise
 517   = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
 518          nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
 519                       nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
 520          nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
 521
 522 ppr_opfix :: (Name, Fixity) -> SDoc
 523 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
 524    where
 525      pp_op | op == negateName = ptext (sLit "prefix `-'")
 526            | otherwise        = quotes (ppr op)
 527 \end{code}
 528
 529 %*********************************************************
 530 %*                                                      *
 531 \subsection{Errors}
 532 %*                                                      *
 533 %*********************************************************
 534
 535 \begin{code}
 536 forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
 537            -> TcRnIf TcGblEnv TcLclEnv ()
 538 forAllWarn doc ty (L loc tyvar)
 539   = ifOptM Opt_WarnUnusedMatches        $
 540     addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar),
 541                         nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))]
 542                    $$
 543                    doc)
 544
 545 opTyErr :: RdrName -> HsType RdrName -> SDoc
 546 opTyErr op ty@(HsOpTy ty1 _ _)
 547   = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
 548          2 extra
 549   where
 550     extra | op == dot_tv_RDR && forall_head ty1
 551           = perhapsForallMsg
 552           | otherwise
 553           = ptext (sLit "Use -XTypeOperators to allow operators in types")
 554
 555     forall_head (L _ (HsTyVar tv))   = tv == forall_tv_RDR
 556     forall_head (L _ (HsAppTy ty _)) = forall_head ty
 557     forall_head _other               = False
 558 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
 559 \end{code}