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 CmdLineOpts      ( opt_GlasgowExts )
  29 import PrelInfo         ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR,
  30                           creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
  31                           ratioDataCon_RDR, negate_RDR
  32                         )
  33 import TysPrim          ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
  34                           floatPrimTyCon, doublePrimTyCon
  35                         )
  36 import TyCon            ( TyCon )
  37 import Id               ( GenId )
  38 import ErrUtils         ( addErrLoc, addShortErrLocLine )
  39 import Name
  40 import Pretty
  41 import UniqFM           ( lookupUFM{-, ufmToList ToDo:rm-} )
  42 import UniqSet          ( emptyUniqSet, unitUniqSet,
  43                           unionUniqSets, unionManyUniqSets,
  44                           SYN_IE(UniqSet)
  45                         )
  46 import PprStyle         ( PprStyle(..) )
  47 import Util             ( Ord3(..), removeDups, panic, pprPanic, assertPanic )
  48 import Outputable
  49
  50 \end{code}
  51
  52
  53 *********************************************************
  54 *                                                       *
  55 \subsection{Patterns}
  56 *                                                       *
  57 *********************************************************
  58
  59 \begin{code}
  60 rnPat :: RdrNamePat -> RnMS s RenamedPat
  61
  62 rnPat WildPatIn = returnRn WildPatIn
  63
  64 rnPat (VarPatIn name)
  65   = lookupBndrRn  name                  `thenRn` \ vname ->
  66     returnRn (VarPatIn vname)
  67
  68 rnPat (LitPatIn lit)
  69   = litOccurrence lit                   `thenRn_`
  70     lookupImplicitOccRn eqClass_RDR     `thenRn_`       -- Needed to find equality on pattern
  71     returnRn (LitPatIn lit)
  72
  73 rnPat (LazyPatIn pat)
  74   = rnPat pat           `thenRn` \ pat' ->
  75     returnRn (LazyPatIn pat')
  76
  77 rnPat (AsPatIn name pat)
  78   = rnPat pat           `thenRn` \ pat' ->
  79     lookupBndrRn name   `thenRn` \ vname ->
  80     returnRn (AsPatIn vname pat')
  81
  82 rnPat (ConPatIn con pats)
  83   = lookupOccRn con     `thenRn` \ con' ->
  84     mapRn rnPat pats    `thenRn` \ patslist ->
  85     returnRn (ConPatIn con' patslist)
  86
  87 rnPat (ConOpPatIn pat1 con _ pat2)
  88   = rnPat pat1          `thenRn` \ pat1' ->
  89     lookupOccRn con     `thenRn` \ con' ->
  90     lookupFixity con    `thenRn` \ fixity ->
  91     rnPat pat2          `thenRn` \ pat2' ->
  92     mkConOpPatRn pat1' con' fixity pat2'
  93
  94 -- Negated patters can only be literals, and they are dealt with
  95 -- by negating the literal at compile time, not by using the negation
  96 -- operation in Num.  So we don't need to make an implicit reference
  97 -- to negate_RDR.
  98 rnPat neg@(NegPatIn pat)
  99   = checkRn (valid_neg_pat pat) (negPatErr neg)
 100                         `thenRn_`
 101     rnPat pat           `thenRn` \ pat' ->
 102     returnRn (NegPatIn pat')
 103   where
 104     valid_neg_pat (LitPatIn (HsInt  _)) = True
 105     valid_neg_pat (LitPatIn (HsFrac _)) = True
 106     valid_neg_pat _                     = False
 107
 108 rnPat (ParPatIn pat)
 109   = rnPat pat           `thenRn` \ pat' ->
 110     returnRn (ParPatIn pat')
 111
 112 rnPat (NPlusKPatIn name lit)
 113   = litOccurrence lit                   `thenRn_`
 114     lookupImplicitOccRn ordClass_RDR    `thenRn_`
 115     lookupBndrRn name                   `thenRn` \ name' ->
 116     returnRn (NPlusKPatIn name' lit)
 117
 118 rnPat (ListPatIn pats)
 119   = addImplicitOccRn listType_name      `thenRn_`
 120     mapRn rnPat pats                    `thenRn` \ patslist ->
 121     returnRn (ListPatIn patslist)
 122
 123 rnPat (TuplePatIn pats)
 124   = addImplicitOccRn (tupleType_name (length pats))     `thenRn_`
 125     mapRn rnPat pats                                    `thenRn` \ patslist ->
 126     returnRn (TuplePatIn patslist)
 127
 128 rnPat (RecPatIn con rpats)
 129   = lookupOccRn con     `thenRn` \ con' ->
 130     rnRpats rpats       `thenRn` \ rpats' ->
 131     returnRn (RecPatIn con' rpats')
 132 \end{code}
 133
 134 ************************************************************************
 135 *                                                                       *
 136 \subsection{Match}
 137 *                                                                       *
 138 ************************************************************************
 139
 140 \begin{code}
 141 --rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
 142
 143 rnMatch (PatMatch pat match)
 144   = bindLocalsRn "pattern" binders      $ \ new_binders ->
 145     rnPat pat                           `thenRn` \ pat' ->
 146     rnMatch match                       `thenRn` \ (match', fvMatch) ->
 147     returnRn (PatMatch pat' match', fvMatch `minusNameSet` mkNameSet new_binders)
 148  where
 149     binders = collectPatBinders pat
 150
 151 rnMatch (GRHSMatch grhss_and_binds)
 152   = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
 153     returnRn (GRHSMatch grhss_and_binds', fvs)
 154 \end{code}
 155
 156 %************************************************************************
 157 %*                                                                      *
 158 \subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
 159 %*                                                                      *
 160 %************************************************************************
 161
 162 \begin{code}
 163 --rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
 164
 165 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
 166   = rnBinds binds               $ \ binds' ->
 167     rnGRHSs grhss               `thenRn` \ (grhss', fvGRHS) ->
 168     returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS)
 169   where
 170     rnGRHSs [] = returnRn ([], emptyNameSet)
 171
 172     rnGRHSs (grhs:grhss)
 173       = rnGRHS  grhs   `thenRn` \ (grhs',  fvs) ->
 174         rnGRHSs grhss  `thenRn` \ (grhss', fvss) ->
 175         returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
 176
 177     rnGRHS (GRHS guard expr locn)
 178       = pushSrcLocRn locn $
 179         (if not (opt_GlasgowExts || is_standard_guard guard) then
 180                 addWarnRn (nonStdGuardErr guard)
 181          else
 182                 returnRn ()
 183         )               `thenRn_`
 184
 185         (rnStmts rnExpr guard   $ \ guard' ->
 186                 -- This nested thing deals with scope and
 187                 -- the free vars of the guard, and knocking off the
 188                 -- free vars of the rhs that are bound by the guard
 189
 190         rnExpr expr     `thenRn` \ (expr',  fvse) ->
 191         returnRn (GRHS guard' expr' locn, fvse))
 192
 193     rnGRHS (OtherwiseGRHS expr locn)
 194       = pushSrcLocRn locn $
 195         rnExpr expr     `thenRn` \ (expr', fvs) ->
 196         returnRn (GRHS [] expr' locn, fvs)
 197
 198         -- Standard Haskell 1.4 guards are just a single boolean
 199         -- expression, rather than a list of qualifiers as in the
 200         -- Glasgow extension
 201     is_standard_guard [GuardStmt _ _] = True
 202     is_standard_guard other           = False
 203 \end{code}
 204
 205 %************************************************************************
 206 %*                                                                      *
 207 \subsubsection{Expressions}
 208 %*                                                                      *
 209 %************************************************************************
 210
 211 \begin{code}
 212 --rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
 213 rnExprs ls =
 214  rnExprs' ls [] `thenRn` \  (exprs, fvExprs) ->
 215  returnRn (exprs, unionManyNameSets fvExprs)
 216
 217 rnExprs' [] acc = returnRn ([], acc)
 218 rnExprs' (expr:exprs) acc
 219   = rnExpr expr                 `thenRn` \ (expr', fvExpr) ->
 220     rnExprs' exprs (fvExpr:acc) `thenRn` \ (exprs', fvExprs) ->
 221     returnRn (expr':exprs', fvExprs)
 222 \end{code}
 223
 224 Variables. We look up the variable and return the resulting name.  The
 225 interesting question is what the free-variable set should be.  We
 226 don't want to return imported or prelude things as free vars.  So we
 227 look at the Name returned from the lookup, and make it part of the
 228 free-var set iff if it's a LocallyDefined Name.
 229 \end{itemize}
 230
 231 \begin{code}
 232 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 233
 234 rnExpr (HsVar v)
 235   = lookupOccRn v       `thenRn` \ vname ->
 236     returnRn (HsVar vname, if isLocallyDefined vname
 237                            then unitNameSet vname
 238                            else emptyUniqSet)
 239
 240 rnExpr (HsLit lit)
 241   = litOccurrence lit           `thenRn_`
 242     returnRn (HsLit lit, emptyNameSet)
 243
 244 rnExpr (HsLam match)
 245   = rnMatch match       `thenRn` \ (match', fvMatch) ->
 246     returnRn (HsLam match', fvMatch)
 247
 248 rnExpr (HsApp fun arg)
 249   = rnExpr fun          `thenRn` \ (fun',fvFun) ->
 250     rnExpr arg          `thenRn` \ (arg',fvArg) ->
 251     returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
 252
 253 rnExpr (OpApp e1 op@(HsVar op_name) _ e2)
 254   = rnExpr e1                           `thenRn` \ (e1', fv_e1) ->
 255     rnExpr e2                           `thenRn` \ (e2', fv_e2) ->
 256     rnExpr op                           `thenRn` \ (op', fv_op) ->
 257
 258         -- Deal wth fixity
 259     lookupFixity op_name                `thenRn` \ fixity ->
 260     getModeRn                           `thenRn` \ mode ->
 261     (case mode of
 262         SourceMode    -> mkOpAppRn e1' op' fixity e2'
 263         InterfaceMode -> returnRn (OpApp e1' op' fixity e2')
 264     )                                   `thenRn` \ final_e ->
 265
 266     returnRn (final_e,
 267               fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2)
 268
 269 rnExpr (NegApp e n)
 270   = rnExpr e                            `thenRn` \ (e', fv_e) ->
 271     lookupImplicitOccRn negate_RDR      `thenRn` \ neg ->
 272     getModeRn                           `thenRn` \ mode ->
 273     mkNegAppRn mode e' (HsVar neg)      `thenRn` \ final_e ->
 274     returnRn (final_e, fv_e)
 275
 276 rnExpr (HsPar e)
 277   = rnExpr e            `thenRn` \ (e', fvs_e) ->
 278     returnRn (HsPar e', fvs_e)
 279
 280 rnExpr (SectionL expr op)
 281   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 282     rnExpr op           `thenRn` \ (op', fvs_op) ->
 283     returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
 284
 285 rnExpr (SectionR op expr)
 286   = rnExpr op           `thenRn` \ (op',   fvs_op) ->
 287     rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 288     returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
 289
 290 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
 291   = lookupImplicitOccRn ccallableClass_RDR      `thenRn_`
 292     lookupImplicitOccRn creturnableClass_RDR    `thenRn_`
 293     rnExprs args                                `thenRn` \ (args', fvs_args) ->
 294     returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
 295
 296 rnExpr (HsSCC label expr)
 297   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 298     returnRn (HsSCC label expr', fvs_expr)
 299
 300 rnExpr (HsCase expr ms src_loc)
 301   = pushSrcLocRn src_loc $
 302     rnExpr expr                 `thenRn` \ (new_expr, e_fvs) ->
 303     mapAndUnzipRn rnMatch ms    `thenRn` \ (new_ms, ms_fvs) ->
 304     returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
 305
 306 rnExpr (HsLet binds expr)
 307   = rnBinds binds               $ \ binds' ->
 308     rnExpr expr                  `thenRn` \ (expr',fvExpr) ->
 309     returnRn (HsLet binds' expr', fvExpr)
 310
 311 rnExpr (HsDo do_or_lc stmts src_loc)
 312   = pushSrcLocRn src_loc $
 313     lookupImplicitOccRn monadZeroClass_RDR      `thenRn_`       -- Forces Monad to come too
 314     (rnStmts rnExpr stmts                       $ \ stmts' ->
 315     returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet))
 316
 317 rnExpr (ExplicitList exps)
 318   = addImplicitOccRn listType_name      `thenRn_`
 319     rnExprs exps                        `thenRn` \ (exps', fvs) ->
 320     returnRn  (ExplicitList exps', fvs)
 321
 322 rnExpr (ExplicitTuple exps)
 323   = addImplicitOccRn (tupleType_name (length exps))     `thenRn_`
 324     rnExprs exps                                        `thenRn` \ (exps', fvExps) ->
 325     returnRn (ExplicitTuple exps', fvExps)
 326
 327 rnExpr (RecordCon (HsVar con) rbinds)
 328   = lookupOccRn con                     `thenRn` \ conname ->
 329     rnRbinds "construction" rbinds      `thenRn` \ (rbinds', fvRbinds) ->
 330     returnRn (RecordCon (HsVar conname) rbinds', fvRbinds)
 331
 332 rnExpr (RecordUpd expr rbinds)
 333   = rnExpr expr                 `thenRn` \ (expr', fvExpr) ->
 334     rnRbinds "update" rbinds    `thenRn` \ (rbinds', fvRbinds) ->
 335     returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
 336
 337 rnExpr (ExprWithTySig expr pty)
 338   = rnExpr expr                                         `thenRn` \ (expr', fvExpr) ->
 339     rnHsSigType (\ sty -> text "an expression") pty     `thenRn` \ pty' ->
 340     returnRn (ExprWithTySig expr' pty', fvExpr)
 341
 342 rnExpr (HsIf p b1 b2 src_loc)
 343   = pushSrcLocRn src_loc $
 344     rnExpr p            `thenRn` \ (p', fvP) ->
 345     rnExpr b1           `thenRn` \ (b1', fvB1) ->
 346     rnExpr b2           `thenRn` \ (b2', fvB2) ->
 347     returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
 348
 349 rnExpr (ArithSeqIn seq)
 350   = lookupImplicitOccRn enumClass_RDR   `thenRn_`
 351     rn_seq seq                          `thenRn` \ (new_seq, fvs) ->
 352     returnRn (ArithSeqIn new_seq, fvs)
 353   where
 354     rn_seq (From expr)
 355      = rnExpr expr      `thenRn` \ (expr', fvExpr) ->
 356        returnRn (From expr', fvExpr)
 357
 358     rn_seq (FromThen expr1 expr2)
 359      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 360        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 361        returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 362
 363     rn_seq (FromTo expr1 expr2)
 364      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 365        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 366        returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 367
 368     rn_seq (FromThenTo expr1 expr2 expr3)
 369      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 370        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 371        rnExpr expr3     `thenRn` \ (expr3', fvExpr3) ->
 372        returnRn (FromThenTo expr1' expr2' expr3',
 373                   unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
 374 \end{code}
 375
 376 %************************************************************************
 377 %*                                                                      *
 378 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 379 %*                                                                      *
 380 %************************************************************************
 381
 382 \begin{code}
 383 rnRbinds str rbinds
 384   = mapRn field_dup_err dup_fields      `thenRn_`
 385     mapAndUnzipRn rn_rbind rbinds       `thenRn` \ (rbinds', fvRbind_s) ->
 386     returnRn (rbinds', unionManyNameSets fvRbind_s)
 387   where
 388     (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
 389
 390     field_dup_err dups = addErrRn (dupFieldErr str dups)
 391
 392     rn_rbind (field, expr, pun)
 393       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 394         rnExpr expr             `thenRn` \ (expr', fvExpr) ->
 395         returnRn ((fieldname, expr', pun), fvExpr)
 396
 397 rnRpats rpats
 398   = mapRn field_dup_err dup_fields      `thenRn_`
 399     mapRn rn_rpat rpats
 400   where
 401     (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
 402
 403     field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
 404
 405     rn_rpat (field, pat, pun)
 406       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 407         rnPat pat               `thenRn` \ pat' ->
 408         returnRn (fieldname, pat', pun)
 409 \end{code}
 410
 411 %************************************************************************
 412 %*                                                                      *
 413 \subsubsection{@Stmt@s: in @do@ expressions}
 414 %*                                                                      *
 415 %************************************************************************
 416
 417 Note that although some bound vars may appear in the free var set for
 418 the first qual, these will eventually be removed by the caller. For
 419 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
 420 @[q <- r, p <- q]@, the free var set for @q <- r@ will
 421 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 422 @r@ will be removed only when we finally return from examining all the
 423 Quals.
 424
 425 \begin{code}
 426 type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 427
 428 rnStmts :: RnExprTy s
 429         -> [RdrNameStmt]
 430         -> ([RenamedStmt] -> RnMS s (a, FreeVars))
 431         -> RnMS s (a, FreeVars)
 432
 433 rnStmts rn_expr [] thing_inside
 434   = thing_inside []
 435
 436 rnStmts rn_expr (stmt:stmts) thing_inside
 437   = rnStmt rn_expr stmt                         $ \ stmt' ->
 438     rnStmts rn_expr stmts                       $ \ stmts' ->
 439     thing_inside (stmt' : stmts')
 440
 441 rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
 442 -- Because of mutual recursion we have to pass in rnExpr.
 443
 444 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
 445   = pushSrcLocRn src_loc $
 446     rn_expr expr                                        `thenRn` \ (expr', fv_expr) ->
 447     bindLocalsRn "pattern in do binding" binders        $ \ new_binders ->
 448     rnPat pat                                           `thenRn` \ pat' ->
 449
 450     thing_inside (BindStmt pat' expr' src_loc)          `thenRn` \ (result, fvs) ->
 451     returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
 452   where
 453     binders = collectPatBinders pat
 454
 455 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
 456   = pushSrcLocRn src_loc $
 457     rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 458     thing_inside (ExprStmt expr' src_loc)       `thenRn` \ (result, fvs) ->
 459     returnRn (result, fv_expr `unionNameSets` fvs)
 460
 461 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
 462   = pushSrcLocRn src_loc $
 463     rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 464     thing_inside (GuardStmt expr' src_loc)      `thenRn` \ (result, fvs) ->
 465     returnRn (result, fv_expr `unionNameSets` fvs)
 466
 467 rnStmt rn_expr (ReturnStmt expr) thing_inside
 468   = rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 469     thing_inside (ReturnStmt expr')             `thenRn` \ (result, fvs) ->
 470     returnRn (result, fv_expr `unionNameSets` fvs)
 471
 472 rnStmt rn_expr (LetStmt binds) thing_inside
 473   = rnBinds binds               $ \ binds' ->
 474     thing_inside (LetStmt binds')
 475 \end{code}
 476
 477 %************************************************************************
 478 %*                                                                      *
 479 \subsubsection{Precedence Parsing}
 480 %*                                                                      *
 481 %************************************************************************
 482
 483 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 484 are assumed to be already correctly arranged.  It needs the fixities
 485 recorded in the OpApp nodes, because fixity info applies to the things
 486 the programmer actually wrote, so you can't find it out from the Name.
 487
 488 Furthermore, the second argument is guaranteed not to be another
 489 operator application.  Why? Because the parser parses all
 490 operator appications left-associatively.
 491
 492 \begin{code}
 493 mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
 494           -> RnMS s RenamedHsExpr
 495
 496 mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
 497           op2 fix2 e2
 498   | nofix_error
 499   = addErrRn (precParseErr (get op1,fix1) (get op2,fix2))       `thenRn_`
 500     returnRn (OpApp e1 op2 fix2 e2)
 501
 502   | rearrange_me
 503   = mkOpAppRn e12 op2 fix2 e2           `thenRn` \ new_e ->
 504     returnRn (OpApp e11 op1 fix1 new_e)
 505   where
 506     (nofix_error, rearrange_me) = compareFixity fix1 fix2
 507
 508 mkOpAppRn e1@(NegApp neg_arg neg_op)
 509           op2
 510           fix2@(Fixity prec2 dir2)
 511           e2
 512   | nofix_error
 513   = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
 514     returnRn (OpApp e1 op2 fix2 e2)
 515
 516   | rearrange_me
 517   = mkOpAppRn neg_arg op2 fix2 e2       `thenRn` \ new_e ->
 518     returnRn (NegApp new_e neg_op)
 519   where
 520     fix_neg = Fixity 6 InfixL   -- Precedence of unary negate is wired in as infixl 6!
 521     (nofix_error, rearrange_me) = compareFixity fix_neg fix2
 522
 523 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 524   = ASSERT( right_op_ok fix e2 )
 525     returnRn (OpApp e1 op fix e2)
 526
 527 get (HsVar n) = n
 528
 529 -- Parser left-associates everything, but
 530 -- derived instances may have correctly-associated things to
 531 -- in the right operarand.  So we just check that the right operand is OK
 532 right_op_ok fix1 (OpApp _ _ fix2 _)
 533   = not error_please && associate_right
 534   where
 535     (error_please, associate_right) = compareFixity fix1 fix2
 536 right_op_ok fix1 other
 537   = True
 538
 539 -- Parser initially makes negation bind more tightly than any other operator
 540 mkNegAppRn mode neg_arg neg_op
 541   = ASSERT( not_op_app mode neg_arg )
 542     returnRn (NegApp neg_arg neg_op)
 543
 544 not_op_app SourceMode (OpApp _ _ _ _) = False
 545 not_op_app mode other                 = True
 546 \end{code}
 547
 548 \begin{code}
 549 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
 550              -> RnMS s RenamedPat
 551
 552 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
 553              op2 fix2 p2
 554   | nofix_error
 555   = addErrRn (precParseErr (op1,fix1) (op2,fix2))       `thenRn_`
 556     returnRn (ConOpPatIn p1 op2 fix2 p2)
 557
 558   | rearrange_me
 559   = mkConOpPatRn p12 op2 fix2 p2                `thenRn` \ new_p ->
 560     returnRn (ConOpPatIn p11 op1 fix1 new_p)
 561
 562   where
 563     (nofix_error, rearrange_me) = compareFixity fix1 fix2
 564
 565 mkConOpPatRn p1@(NegPatIn neg_arg)
 566           op2
 567           fix2@(Fixity prec2 dir2)
 568           p2
 569   | prec2 > 6   -- Precedence of unary - is wired in as 6!
 570   = addErrRn (precParseNegPatErr (op2,fix2))    `thenRn_`
 571     returnRn (ConOpPatIn p1 op2 fix2 p2)
 572
 573 mkConOpPatRn p1 op fix p2                       -- Default case, no rearrangment
 574   = ASSERT( not_op_pat p2 )
 575     returnRn (ConOpPatIn p1 op fix p2)
 576
 577 not_op_pat (ConOpPatIn _ _ _ _) = False
 578 not_op_pat other                = True
 579 \end{code}
 580
 581 \begin{code}
 582 checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
 583
 584 checkPrecMatch False fn match
 585   = returnRn ()
 586 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
 587   = checkPrec op p1 False       `thenRn_`
 588     checkPrec op p2 True
 589 checkPrecMatch True op _
 590   = panic "checkPrecMatch"
 591
 592 checkPrec op (ConOpPatIn _ op1 _ _) right
 593   = lookupFixity op     `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
 594     lookupFixity op1    `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
 595     let
 596         inf_ok = op1_prec > op_prec ||
 597                  (op1_prec == op_prec &&
 598                   (op1_dir == InfixR && op_dir == InfixR && right ||
 599                    op1_dir == InfixL && op_dir == InfixL && not right))
 600
 601         info  = (op,op_fix)
 602         info1 = (op1,op1_fix)
 603         (infol, infor) = if right then (info, info1) else (info1, info)
 604     in
 605     checkRn inf_ok (precParseErr infol infor)
 606
 607 checkPrec op (NegPatIn _) right
 608   = lookupFixity op     `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
 609     checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
 610
 611 checkPrec op pat right
 612   = returnRn ()
 613 \end{code}
 614
 615 Consider
 616         a `op1` b `op2` c
 617
 618 (compareFixity op1 op2) tells which way to arrange appication, or
 619 whether there's an error.
 620
 621 \begin{code}
 622 compareFixity :: Fixity -> Fixity
 623               -> (Bool,         -- Error please
 624                   Bool)         -- Associate to the right: a op1 (b op2 c)
 625 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
 626   = case prec1 `cmp` prec2 of
 627         GT_ -> left
 628         LT_ -> right
 629         EQ_ -> case (dir1, dir2) of
 630                         (InfixR, InfixR) -> right
 631                         (InfixL, InfixL) -> left
 632                         _                -> error_please
 633   where
 634     right        = (False, True)
 635     left         = (False, False)
 636     error_please = (True,  False)
 637 \end{code}
 638
 639 %************************************************************************
 640 %*                                                                      *
 641 \subsubsection{Literals}
 642 %*                                                                      *
 643 %************************************************************************
 644
 645 When literals occur we have to make sure that the types and classes they involve
 646 are made available.
 647
 648 \begin{code}
 649 litOccurrence (HsChar _)
 650   = addImplicitOccRn charType_name
 651
 652 litOccurrence (HsCharPrim _)
 653   = addImplicitOccRn (getName charPrimTyCon)
 654
 655 litOccurrence (HsString _)
 656   = addImplicitOccRn listType_name      `thenRn_`
 657     addImplicitOccRn charType_name
 658
 659 litOccurrence (HsStringPrim _)
 660   = addImplicitOccRn (getName addrPrimTyCon)
 661
 662 litOccurrence (HsInt _)
 663   = lookupImplicitOccRn numClass_RDR                    -- Int and Integer are forced in by Num
 664
 665 litOccurrence (HsFrac _)
 666   = lookupImplicitOccRn fractionalClass_RDR     `thenRn_`
 667     lookupImplicitOccRn ratioDataCon_RDR
 668         -- We have to make sure that the Ratio type is imported with
 669         -- its constructor, because literals of type Ratio t are
 670         -- built with that constructor.
 671
 672 litOccurrence (HsIntPrim _)
 673   = addImplicitOccRn (getName intPrimTyCon)
 674
 675 litOccurrence (HsFloatPrim _)
 676   = addImplicitOccRn (getName floatPrimTyCon)
 677
 678 litOccurrence (HsDoublePrim _)
 679   = addImplicitOccRn (getName doublePrimTyCon)
 680
 681 litOccurrence (HsLitLit _)
 682   = lookupImplicitOccRn ccallableClass_RDR
 683 \end{code}
 684
 685
 686 %************************************************************************
 687 %*                                                                      *
 688 \subsubsection{Errors}
 689 %*                                                                      *
 690 %************************************************************************
 691
 692 \begin{code}
 693 dupFieldErr str (dup:rest) sty
 694   = hcat [ptext SLIT("duplicate field name `"),
 695                ppr sty dup,
 696                ptext SLIT("' in record "), text str]
 697
 698 negPatErr pat  sty
 699   = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat]
 700
 701 precParseNegPatErr op sty
 702   = hang (ptext SLIT("precedence parsing error"))
 703       4 (hcat [ptext SLIT("prefix `-' has lower precedence than "),
 704                     pp_op sty op,
 705                     ptext SLIT(" in pattern")])
 706
 707 precParseErr op1 op2  sty
 708   = hang (ptext SLIT("precedence parsing error"))
 709       4 (hcat [ptext SLIT("cannot mix "), pp_op sty op1, ptext SLIT(" and "), pp_op sty op2,
 710                     ptext SLIT(" in the same infix expression")])
 711
 712 nonStdGuardErr guard sty
 713   = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
 714       4 (ppr sty guard)
 715
 716 pp_op sty (op, fix) = hcat [ppr sty op, space, parens (ppr sty fix)]
 717 \end{code}