ghc/compiler/rename/RnExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnExpr]{Renaming of expressions}
   5
   6 Basically dependency analysis.
   7
   8 Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qualifier@ datatypes.  In
   9 general, all of these functions return a renamed thing, and a set of
  10 free variables.
  11
  12 \begin{code}
  13 #include "HsVersions.h"
  14
  15 module RnExpr (
  16         rnMatch, rnGRHSsAndBinds, rnPat,
  17         checkPrecMatch
  18    ) where
  19
  20 IMP_Ubiq()
  21 IMPORT_DELOOPER(RnLoop)         -- break the RnPass/RnExpr/RnBinds loops
  22
  23 import HsSyn
  24 import RdrHsSyn
  25 import RnHsSyn
  26 import RnMonad
  27 import RnEnv
  28 import PrelInfo         ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR,
  29                           creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR,
  30                           negate_RDR
  31                         )
  32 import TysPrim          ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
  33                           floatPrimTyCon, doublePrimTyCon
  34                         )
  35 import TyCon            ( TyCon )
  36 import ErrUtils         ( addErrLoc, addShortErrLocLine )
  37 import Name
  38 import Pretty
  39 import UniqFM           ( lookupUFM{-, ufmToList ToDo:rm-} )
  40 import UniqSet          ( emptyUniqSet, unitUniqSet,
  41                           unionUniqSets, unionManyUniqSets,
  42                           SYN_IE(UniqSet)
  43                         )
  44 import Util             ( Ord3(..), removeDups, panic )
  45 \end{code}
  46
  47
  48 *********************************************************
  49 *                                                       *
  50 \subsection{Patterns}
  51 *                                                       *
  52 *********************************************************
  53
  54 \begin{code}
  55 rnPat :: RdrNamePat -> RnMS s RenamedPat
  56
  57 rnPat WildPatIn = returnRn WildPatIn
  58
  59 rnPat (VarPatIn name)
  60   = lookupRn name       `thenRn` \ vname ->
  61     returnRn (VarPatIn vname)
  62
  63 rnPat (LitPatIn lit)
  64   = litOccurrence lit                   `thenRn_`
  65     lookupImplicitOccRn eqClass_RDR     `thenRn_`       -- Needed to find equality on pattern
  66     returnRn (LitPatIn lit)
  67
  68 rnPat (LazyPatIn pat)
  69   = rnPat pat           `thenRn` \ pat' ->
  70     returnRn (LazyPatIn pat')
  71
  72 rnPat (AsPatIn name pat)
  73   = rnPat pat           `thenRn` \ pat' ->
  74     lookupRn name       `thenRn` \ vname ->
  75     returnRn (AsPatIn vname pat')
  76
  77 rnPat (ConPatIn con pats)
  78   = lookupRn con        `thenRn` \ con' ->
  79     mapRn rnPat pats    `thenRn` \ patslist ->
  80     returnRn (ConPatIn con' patslist)
  81
  82 rnPat (ConOpPatIn pat1 con pat2)
  83   = rnOpPat pat1 con pat2
  84
  85 -- Negated patters can only be literals, and they are dealt with
  86 -- by negating the literal at compile time, not by using the negation
  87 -- operation in Num.  So we don't need to make an implicit reference
  88 -- to negate_RDR.
  89 rnPat neg@(NegPatIn pat)
  90   = checkRn (valid_neg_pat pat) (negPatErr neg)
  91                         `thenRn_`
  92     rnPat pat           `thenRn` \ pat' ->
  93     returnRn (NegPatIn pat')
  94   where
  95     valid_neg_pat (LitPatIn (HsInt  _)) = True
  96     valid_neg_pat (LitPatIn (HsFrac _)) = True
  97     valid_neg_pat _                     = False
  98
  99 rnPat (ParPatIn pat)
 100   = rnPat pat           `thenRn` \ pat' ->
 101     returnRn (ParPatIn pat')
 102
 103 rnPat (ListPatIn pats)
 104   = addImplicitOccRn listType_name      `thenRn_`
 105     mapRn rnPat pats                    `thenRn` \ patslist ->
 106     returnRn (ListPatIn patslist)
 107
 108 rnPat (TuplePatIn pats)
 109   = addImplicitOccRn (tupleType_name (length pats))     `thenRn_`
 110     mapRn rnPat pats                                    `thenRn` \ patslist ->
 111     returnRn (TuplePatIn patslist)
 112
 113 rnPat (RecPatIn con rpats)
 114   = lookupRn con        `thenRn` \ con' ->
 115     rnRpats rpats       `thenRn` \ rpats' ->
 116     returnRn (RecPatIn con' rpats')
 117 \end{code}
 118
 119 ************************************************************************
 120 *                                                                       *
 121 \subsection{Match}
 122 *                                                                       *
 123 ************************************************************************
 124
 125 \begin{code}
 126 rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
 127
 128 rnMatch (PatMatch pat match)
 129   = bindLocalsRn "pattern" binders      $ \ new_binders ->
 130     rnPat pat                           `thenRn` \ pat' ->
 131     rnMatch match                       `thenRn` \ (match', fvMatch) ->
 132     returnRn (PatMatch pat' match', fvMatch `minusNameSet` mkNameSet new_binders)
 133  where
 134     binders = collectPatBinders pat
 135
 136 rnMatch (GRHSMatch grhss_and_binds)
 137   = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
 138     returnRn (GRHSMatch grhss_and_binds', fvs)
 139 \end{code}
 140
 141 %************************************************************************
 142 %*                                                                      *
 143 \subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
 144 %*                                                                      *
 145 %************************************************************************
 146
 147 \begin{code}
 148 rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
 149
 150 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
 151   = rnBinds binds               $ \ binds' ->
 152     rnGRHSs grhss               `thenRn` \ (grhss', fvGRHS) ->
 153     returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS)
 154   where
 155     rnGRHSs [] = returnRn ([], emptyNameSet)
 156
 157     rnGRHSs (grhs:grhss)
 158       = rnGRHS  grhs   `thenRn` \ (grhs',  fvs) ->
 159         rnGRHSs grhss  `thenRn` \ (grhss', fvss) ->
 160         returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
 161
 162     rnGRHS (GRHS guard expr locn)
 163       = pushSrcLocRn locn $
 164         rnExpr guard    `thenRn` \ (guard', fvsg) ->
 165         rnExpr expr     `thenRn` \ (expr',  fvse) ->
 166         returnRn (GRHS guard' expr' locn, fvsg `unionNameSets` fvse)
 167
 168     rnGRHS (OtherwiseGRHS expr locn)
 169       = pushSrcLocRn locn $
 170         rnExpr expr     `thenRn` \ (expr', fvs) ->
 171         returnRn (OtherwiseGRHS expr' locn, fvs)
 172 \end{code}
 173
 174 %************************************************************************
 175 %*                                                                      *
 176 \subsubsection{Expressions}
 177 %*                                                                      *
 178 %************************************************************************
 179
 180 \begin{code}
 181 rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
 182
 183 rnExprs [] = returnRn ([], emptyNameSet)
 184
 185 rnExprs (expr:exprs)
 186   = rnExpr expr         `thenRn` \ (expr', fvExpr) ->
 187     rnExprs exprs       `thenRn` \ (exprs', fvExprs) ->
 188     returnRn (expr':exprs', fvExpr `unionNameSets` fvExprs)
 189 \end{code}
 190
 191 Variables. We look up the variable and return the resulting name.  The
 192 interesting question is what the free-variable set should be.  We
 193 don't want to return imported or prelude things as free vars.  So we
 194 look at the Name returned from the lookup, and make it part of the
 195 free-var set iff if it's a LocallyDefined Name.
 196 \end{itemize}
 197
 198 \begin{code}
 199 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 200
 201 rnExpr (HsVar v)
 202   = lookupOccRn v       `thenRn` \ vname ->
 203     returnRn (HsVar vname, if isLocallyDefined vname
 204                            then unitNameSet vname
 205                            else emptyUniqSet)
 206
 207 rnExpr (HsLit lit)
 208   = litOccurrence lit           `thenRn_`
 209     returnRn (HsLit lit, emptyNameSet)
 210
 211 rnExpr (HsLam match)
 212   = rnMatch match       `thenRn` \ (match', fvMatch) ->
 213     returnRn (HsLam match', fvMatch)
 214
 215 rnExpr (HsApp fun arg)
 216   = rnExpr fun          `thenRn` \ (fun',fvFun) ->
 217     rnExpr arg          `thenRn` \ (arg',fvArg) ->
 218     returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
 219
 220 rnExpr (OpApp e1 (HsVar op) e2) = rnOpApp e1 op e2
 221
 222 rnExpr (NegApp e n) = completeNegApp (rnExpr e)
 223
 224 rnExpr (HsPar e)
 225   = rnExpr e            `thenRn` \ (e', fvs_e) ->
 226     returnRn (HsPar e', fvs_e)
 227
 228 rnExpr (SectionL expr op)
 229   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 230     rnExpr op           `thenRn` \ (op', fvs_op) ->
 231     returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
 232
 233 rnExpr (SectionR op expr)
 234   = rnExpr op           `thenRn` \ (op',   fvs_op) ->
 235     rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 236     returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
 237
 238 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
 239   = lookupImplicitOccRn ccallableClass_RDR      `thenRn_`
 240     lookupImplicitOccRn creturnableClass_RDR    `thenRn_`
 241     rnExprs args                                `thenRn` \ (args', fvs_args) ->
 242     returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
 243
 244 rnExpr (HsSCC label expr)
 245   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 246     returnRn (HsSCC label expr', fvs_expr)
 247
 248 rnExpr (HsCase expr ms src_loc)
 249   = pushSrcLocRn src_loc $
 250     rnExpr expr                 `thenRn` \ (new_expr, e_fvs) ->
 251     mapAndUnzipRn rnMatch ms    `thenRn` \ (new_ms, ms_fvs) ->
 252     returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
 253
 254 rnExpr (HsLet binds expr)
 255   = rnBinds binds               $ \ binds' ->
 256     rnExpr expr                  `thenRn` \ (expr',fvExpr) ->
 257     returnRn (HsLet binds' expr', fvExpr)
 258
 259 rnExpr (HsDo stmts src_loc)
 260   = pushSrcLocRn src_loc $
 261     lookupImplicitOccRn monadZeroClass_RDR      `thenRn_`       -- Forces Monad to come too
 262     rnStmts stmts                               `thenRn` \ (stmts', fvStmts) ->
 263     returnRn (HsDo stmts' src_loc, fvStmts)
 264
 265 rnExpr (ListComp expr quals)
 266   = addImplicitOccRn listType_name      `thenRn_`
 267     rnQuals expr quals                  `thenRn` \ ((expr', quals'), fvs) ->
 268     returnRn (ListComp expr' quals', fvs)
 269
 270 rnExpr (ExplicitList exps)
 271   = addImplicitOccRn listType_name      `thenRn_`
 272     rnExprs exps                        `thenRn` \ (exps', fvs) ->
 273     returnRn  (ExplicitList exps', fvs)
 274
 275 rnExpr (ExplicitTuple exps)
 276   = addImplicitOccRn (tupleType_name (length exps))     `thenRn_`
 277     rnExprs exps                                        `thenRn` \ (exps', fvExps) ->
 278     returnRn (ExplicitTuple exps', fvExps)
 279
 280 rnExpr (RecordCon (HsVar con) rbinds)
 281   = lookupOccRn con                     `thenRn` \ conname ->
 282     rnRbinds "construction" rbinds      `thenRn` \ (rbinds', fvRbinds) ->
 283     returnRn (RecordCon (HsVar conname) rbinds', fvRbinds)
 284
 285 rnExpr (RecordUpd expr rbinds)
 286   = rnExpr expr                 `thenRn` \ (expr', fvExpr) ->
 287     rnRbinds "update" rbinds    `thenRn` \ (rbinds', fvRbinds) ->
 288     returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
 289
 290 rnExpr (ExprWithTySig expr pty)
 291   = rnExpr expr                         `thenRn` \ (expr', fvExpr) ->
 292     rnHsType pty                        `thenRn` \ pty' ->
 293     returnRn (ExprWithTySig expr' pty', fvExpr)
 294
 295 rnExpr (HsIf p b1 b2 src_loc)
 296   = pushSrcLocRn src_loc $
 297     rnExpr p            `thenRn` \ (p', fvP) ->
 298     rnExpr b1           `thenRn` \ (b1', fvB1) ->
 299     rnExpr b2           `thenRn` \ (b2', fvB2) ->
 300     returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
 301
 302 rnExpr (ArithSeqIn seq)
 303   = lookupImplicitOccRn enumClass_RDR   `thenRn_`
 304     rn_seq seq                          `thenRn` \ (new_seq, fvs) ->
 305     returnRn (ArithSeqIn new_seq, fvs)
 306   where
 307     rn_seq (From expr)
 308      = rnExpr expr      `thenRn` \ (expr', fvExpr) ->
 309        returnRn (From expr', fvExpr)
 310
 311     rn_seq (FromThen expr1 expr2)
 312      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 313        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 314        returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 315
 316     rn_seq (FromTo expr1 expr2)
 317      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 318        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 319        returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 320
 321     rn_seq (FromThenTo expr1 expr2 expr3)
 322      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 323        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 324        rnExpr expr3     `thenRn` \ (expr3', fvExpr3) ->
 325        returnRn (FromThenTo expr1' expr2' expr3',
 326                   unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
 327 \end{code}
 328
 329 %************************************************************************
 330 %*                                                                      *
 331 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 332 %*                                                                      *
 333 %************************************************************************
 334
 335 \begin{code}
 336 rnRbinds str rbinds
 337   = mapRn field_dup_err dup_fields      `thenRn_`
 338     mapAndUnzipRn rn_rbind rbinds       `thenRn` \ (rbinds', fvRbind_s) ->
 339     returnRn (rbinds', unionManyNameSets fvRbind_s)
 340   where
 341     (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
 342
 343     field_dup_err dups = addErrRn (dupFieldErr str dups)
 344
 345     rn_rbind (field, expr, pun)
 346       = lookupOccRn field       `thenRn` \ fieldname ->
 347         rnExpr expr             `thenRn` \ (expr', fvExpr) ->
 348         returnRn ((fieldname, expr', pun), fvExpr)
 349
 350 rnRpats rpats
 351   = mapRn field_dup_err dup_fields      `thenRn_`
 352     mapRn rn_rpat rpats
 353   where
 354     (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
 355
 356     field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
 357
 358     rn_rpat (field, pat, pun)
 359       = lookupOccRn field       `thenRn` \ fieldname ->
 360         rnPat pat               `thenRn` \ pat' ->
 361         returnRn (fieldname, pat', pun)
 362 \end{code}
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \subsubsection{@Qualifier@s: in list comprehensions}
 367 %*                                                                      *
 368 %************************************************************************
 369
 370 Note that although some bound vars may appear in the free var set for
 371 the first qual, these will eventually be removed by the caller. For
 372 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
 373 @[q <- r, p <- q]@, the free var set for @q <- r@ will
 374 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 375 @r@ will be removed only when we finally return from examining all the
 376 Quals.
 377
 378 \begin{code}
 379 rnQuals :: RdrNameHsExpr -> [RdrNameQual]
 380          -> RnMS s ((RenamedHsExpr, [RenamedQual]), FreeVars)
 381
 382 rnQuals expr [qual]                             -- must be at least one qual
 383   = rnQual qual                         $ \ new_qual ->
 384     rnExpr expr                         `thenRn` \ (expr', fvs) ->
 385     returnRn ((expr', [new_qual]), fvs)
 386
 387 rnQuals expr (qual: quals)
 388   = rnQual qual                 $ \ qual' ->
 389     rnQuals expr quals          `thenRn` \ ((expr', quals'), fv_quals) ->
 390     returnRn ((expr', qual' : quals'), fv_quals)
 391
 392
 393 -- rnQual :: RdrNameQual
 394 --        -> (RenamedQual -> RnMS s (a,FreeVars))
 395 --        -> RnMS s (a,FreeVars)
 396 -- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2]
 397
 398 rnQual (GeneratorQual pat expr) thing_inside
 399   = rnExpr expr                                                 `thenRn` \ (expr', fv_expr) ->
 400     bindLocalsRn "pattern in list comprehension" binders        $ \ new_binders ->
 401     rnPat pat                                                   `thenRn` \ pat' ->
 402
 403     thing_inside (GeneratorQual pat' expr')             `thenRn` \ (result, fvs) ->
 404     returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
 405   where
 406     binders = collectPatBinders pat
 407
 408 rnQual (FilterQual expr) thing_inside
 409   = rnExpr expr                         `thenRn` \ (expr', fv_expr) ->
 410     thing_inside (FilterQual expr')     `thenRn` \ (result, fvs) ->
 411     returnRn (result, fv_expr `unionNameSets` fvs)
 412
 413 rnQual (LetQual binds) thing_inside
 414   = rnBinds binds                       $ \ binds' ->
 415     thing_inside (LetQual binds')
 416 \end{code}
 417
 418
 419 %************************************************************************
 420 %*                                                                      *
 421 \subsubsection{@Stmt@s: in @do@ expressions}
 422 %*                                                                      *
 423 %************************************************************************
 424
 425 \begin{code}
 426 rnStmts :: [RdrNameStmt] -> RnMS s ([RenamedStmt], FreeVars)
 427
 428 rnStmts [stmt@(ExprStmt expr src_loc)]          -- last stmt must be ExprStmt
 429   = pushSrcLocRn src_loc $
 430     rnExpr expr                         `thenRn` \ (expr', fv_expr) ->
 431     returnRn ([ExprStmt expr' src_loc], fv_expr)
 432
 433 rnStmts (stmt:stmts)
 434   = rnStmt stmt                         $ \ stmt' ->
 435     rnStmts stmts                       `thenRn` \ (stmts', fv_stmts) ->
 436     returnRn (stmt':stmts', fv_stmts)
 437
 438
 439 -- rnStmt :: RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
 440 -- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2]
 441
 442 rnStmt (BindStmt pat expr src_loc) thing_inside
 443   = pushSrcLocRn src_loc $
 444     rnExpr expr                                         `thenRn` \ (expr', fv_expr) ->
 445     bindLocalsRn "pattern in do binding" binders        $ \ new_binders ->
 446     rnPat pat                                           `thenRn` \ pat' ->
 447
 448     thing_inside (BindStmt pat' expr' src_loc)          `thenRn` \ (result, fvs) ->
 449     returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
 450   where
 451     binders = collectPatBinders pat
 452
 453 rnStmt (ExprStmt expr src_loc) thing_inside
 454   = pushSrcLocRn src_loc $
 455     rnExpr expr                                 `thenRn` \ (expr', fv_expr) ->
 456     thing_inside (ExprStmt expr' src_loc)       `thenRn` \ (result, fvs) ->
 457     returnRn (result, fv_expr `unionNameSets` fvs)
 458
 459 rnStmt (LetStmt binds) thing_inside
 460   = rnBinds binds               $ \ binds' ->
 461     thing_inside (LetStmt binds')
 462 \end{code}
 463
 464 %************************************************************************
 465 %*                                                                      *
 466 \subsubsection{Precedence Parsing}
 467 %*                                                                      *
 468 %************************************************************************
 469
 470 @rnOpApp@ deals with operator applications.  It does some rearrangement of
 471 the expression so that the precedences are right.  This must be done on the
 472 expression *before* renaming, because fixity info applies to the things
 473 the programmer actually wrote.
 474
 475 \begin{code}
 476 rnOpApp (NegApp e11 n) op e2
 477   = lookupFixity op             `thenRn` \ (Fixity op_prec op_dir) ->
 478     if op_prec > 6 then
 479         -- negate precedence 6 wired in
 480         -- (-x)*y  ==> -(x*y)
 481         completeNegApp (rnOpApp e11 op e2)
 482     else
 483         completeOpApp (completeNegApp (rnExpr e11)) op (rnExpr e2)
 484
 485 rnOpApp (OpApp e11 (HsVar op1) e12) op e2
 486   = lookupFixity op              `thenRn` \ op_fix@(Fixity op_prec  op_dir) ->
 487     lookupFixity op1             `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
 488     -- pprTrace "rnOpApp:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $
 489     case (op1_prec `cmp` op_prec) of
 490       LT_  -> rearrange
 491       EQ_  -> case (op1_dir, op_dir) of
 492                 (InfixR, InfixR) -> rearrange
 493                 (InfixL, InfixL) -> dont_rearrange
 494                 _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix))  `thenRn_`
 495                      dont_rearrange
 496       GT__ -> dont_rearrange
 497   where
 498     rearrange      = rnOpApp e11 op1 (OpApp e12 (HsVar op) e2)
 499     dont_rearrange = completeOpApp (rnOpApp e11 op1 e12) op (rnExpr e2)
 500
 501 rnOpApp e1 op e2 = completeOpApp (rnExpr e1) op (rnExpr e2)
 502
 503 completeOpApp rn_e1 op rn_e2
 504   = rn_e1               `thenRn` \ (e1', fvs1) ->
 505     rn_e2               `thenRn` \ (e2', fvs2) ->
 506     rnExpr (HsVar op)   `thenRn` \ (op', fvs3) ->
 507     returnRn (OpApp e1' op' e2', fvs1 `unionNameSets` fvs2 `unionNameSets` fvs3)
 508
 509 completeNegApp rn_expr
 510   = rn_expr                             `thenRn` \ (e', fvs_e) ->
 511     lookupImplicitOccRn negate_RDR      `thenRn` \ neg ->
 512     returnRn (NegApp e' (HsVar neg), fvs_e)
 513 \end{code}
 514
 515 \begin{code}
 516 rnOpPat p1@(NegPatIn p11) op p2
 517   = lookupFixity op             `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
 518     if op_prec > 6 then
 519         -- negate precedence 6 wired in
 520         addErrRn (precParseNegPatErr (op,op_fix))       `thenRn_`
 521         rnOpPat p11 op p2                               `thenRn` \ op_pat ->
 522         returnRn (NegPatIn op_pat)
 523     else
 524         completeOpPat (rnPat p1) op (rnPat p2)
 525
 526 rnOpPat (ConOpPatIn p11 op1 p12) op p2
 527   = lookupFixity op              `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
 528     lookupFixity op1             `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
 529     case (op1_prec `cmp` op_prec) of
 530       LT_  -> rearrange
 531       EQ_  -> case (op1_dir, op_dir) of
 532                 (InfixR, InfixR) -> rearrange
 533                 (InfixL, InfixL) -> dont_rearrange
 534                 _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix))  `thenRn_`
 535                      dont_rearrange
 536       GT__ -> dont_rearrange
 537   where
 538     rearrange      = rnOpPat p11 op1 (ConOpPatIn p12 op p2)
 539     dont_rearrange = completeOpPat (rnOpPat p11 op1 p12) op (rnPat p2)
 540
 541
 542 rnOpPat p1 op p2 = completeOpPat (rnPat p1) op (rnPat p2)
 543
 544 completeOpPat rn_p1 op rn_p2
 545   = rn_p1               `thenRn` \ p1' ->
 546     rn_p2               `thenRn` \ p2' ->
 547     lookupRn op         `thenRn` \ op' ->
 548     returnRn (ConOpPatIn p1' op' p2')
 549 \end{code}
 550
 551 \begin{code}
 552 checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
 553
 554 checkPrecMatch False fn match
 555   = returnRn ()
 556 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
 557   = checkPrec op p1 False       `thenRn_`
 558     checkPrec op p2 True
 559 checkPrecMatch True op _
 560   = panic "checkPrecMatch"
 561
 562 checkPrec op (ConOpPatIn _ op1 _) right
 563   = lookupFixity op     `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
 564     lookupFixity op1    `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
 565     let
 566         inf_ok = op1_prec > op_prec ||
 567                  (op1_prec == op_prec &&
 568                   (op1_dir == InfixR && op_dir == InfixR && right ||
 569                    op1_dir == InfixL && op_dir == InfixL && not right))
 570
 571         info  = (op,op_fix)
 572         info1 = (op1,op1_fix)
 573         (infol, infor) = if right then (info, info1) else (info1, info)
 574     in
 575     checkRn inf_ok (precParseErr infol infor)
 576
 577 checkPrec op (NegPatIn _) right
 578   = lookupFixity op     `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
 579     checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
 580
 581 checkPrec op pat right
 582   = returnRn ()
 583 \end{code}
 584
 585 %************************************************************************
 586 %*                                                                      *
 587 \subsubsection{Literals}
 588 %*                                                                      *
 589 %************************************************************************
 590
 591 When literals occur we have to make sure that the types and classes they involve
 592 are made available.
 593
 594 \begin{code}
 595 litOccurrence (HsChar _)
 596   = addImplicitOccRn charType_name
 597
 598 litOccurrence (HsCharPrim _)
 599   = addImplicitOccRn (getName charPrimTyCon)
 600
 601 litOccurrence (HsString _)
 602   = addImplicitOccRn listType_name      `thenRn_`
 603     addImplicitOccRn charType_name
 604
 605 litOccurrence (HsStringPrim _)
 606   = addImplicitOccRn (getName addrPrimTyCon)
 607
 608 litOccurrence (HsInt _)
 609   = lookupImplicitOccRn numClass_RDR    `thenRn_`       -- Int and Integer are forced in by Num
 610     returnRn ()
 611
 612 litOccurrence (HsFrac _)
 613   = lookupImplicitOccRn fractionalClass_RDR     `thenRn_`       -- ... similarly Rational
 614     returnRn ()
 615
 616 litOccurrence (HsIntPrim _)
 617   = addImplicitOccRn (getName intPrimTyCon)
 618
 619 litOccurrence (HsFloatPrim _)
 620   = addImplicitOccRn (getName floatPrimTyCon)
 621
 622 litOccurrence (HsDoublePrim _)
 623   = addImplicitOccRn (getName doublePrimTyCon)
 624
 625 litOccurrence (HsLitLit _)
 626   = lookupImplicitOccRn ccallableClass_RDR      `thenRn_`
 627     returnRn ()
 628 \end{code}
 629
 630
 631 %************************************************************************
 632 %*                                                                      *
 633 \subsubsection{Errors}
 634 %*                                                                      *
 635 %************************************************************************
 636
 637 \begin{code}
 638 dupFieldErr str (dup:rest) sty
 639   = ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str]
 640
 641 negPatErr pat  sty
 642   = ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat]
 643
 644 precParseNegPatErr op sty
 645   = ppHang (ppStr "precedence parsing error")
 646       4 (ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"])
 647
 648 precParseErr op1 op2  sty
 649   = ppHang (ppStr "precedence parsing error")
 650       4 (ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
 651                     ppStr " in the same infix expression"])
 652
 653 pp_op sty (op, fix) = ppBesides [pprSym sty op, ppLparen, ppr sty fix, ppRparen]
 654 \end{code}