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 BasicTypes       ( Fixity(..), FixityDirection(..) )
  30 import PrelInfo         ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR,
  31                           creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
  32                           ratioDataCon_RDR, negate_RDR
  33                         )
  34 import TysPrim          ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
  35                           floatPrimTyCon, doublePrimTyCon
  36                         )
  37 import TyCon            ( TyCon )
  38 import Id               ( GenId )
  39 import ErrUtils         ( addErrLoc, addShortErrLocLine )
  40 import Name
  41 import Pretty
  42 import UniqFM           ( lookupUFM{-, ufmToList ToDo:rm-} )
  43 import UniqSet          ( emptyUniqSet, unitUniqSet,
  44                           unionUniqSets, unionManyUniqSets,
  45                           SYN_IE(UniqSet)
  46                         )
  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 with fixity
 259         -- When renaming code synthesised from "deriving" declarations
 260         -- we're in Interface mode, and we should ignore fixity; assume
 261         -- that the deriving code generator got the association correct
 262     lookupFixity op_name                `thenRn` \ fixity ->
 263     getModeRn                           `thenRn` \ mode ->
 264     (case mode of
 265         SourceMode      -> mkOpAppRn e1' op' fixity e2'
 266         InterfaceMode _ -> returnRn (OpApp e1' op' fixity e2')
 267     )                                   `thenRn` \ final_e ->
 268
 269     returnRn (final_e,
 270               fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2)
 271
 272 rnExpr (NegApp e n)
 273   = rnExpr e                            `thenRn` \ (e', fv_e) ->
 274     lookupImplicitOccRn negate_RDR      `thenRn` \ neg ->
 275     mkNegAppRn e' (HsVar neg)           `thenRn` \ final_e ->
 276     returnRn (final_e, fv_e)
 277
 278 rnExpr (HsPar e)
 279   = rnExpr e            `thenRn` \ (e', fvs_e) ->
 280     returnRn (HsPar e', fvs_e)
 281
 282 rnExpr (SectionL expr op)
 283   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 284     rnExpr op           `thenRn` \ (op', fvs_op) ->
 285     returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
 286
 287 rnExpr (SectionR op expr)
 288   = rnExpr op           `thenRn` \ (op',   fvs_op) ->
 289     rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 290     returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
 291
 292 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
 293   = lookupImplicitOccRn ccallableClass_RDR      `thenRn_`
 294     lookupImplicitOccRn creturnableClass_RDR    `thenRn_`
 295     rnExprs args                                `thenRn` \ (args', fvs_args) ->
 296     returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
 297
 298 rnExpr (HsSCC label expr)
 299   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 300     returnRn (HsSCC label expr', fvs_expr)
 301
 302 rnExpr (HsCase expr ms src_loc)
 303   = pushSrcLocRn src_loc $
 304     rnExpr expr                 `thenRn` \ (new_expr, e_fvs) ->
 305     mapAndUnzipRn rnMatch ms    `thenRn` \ (new_ms, ms_fvs) ->
 306     returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
 307
 308 rnExpr (HsLet binds expr)
 309   = rnBinds binds               $ \ binds' ->
 310     rnExpr expr                  `thenRn` \ (expr',fvExpr) ->
 311     returnRn (HsLet binds' expr', fvExpr)
 312
 313 rnExpr (HsDo do_or_lc stmts src_loc)
 314   = pushSrcLocRn src_loc $
 315     lookupImplicitOccRn monadZeroClass_RDR      `thenRn_`       -- Forces Monad to come too
 316     (rnStmts rnExpr stmts                       $ \ stmts' ->
 317     returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet))
 318
 319 rnExpr (ExplicitList exps)
 320   = addImplicitOccRn listType_name      `thenRn_`
 321     rnExprs exps                        `thenRn` \ (exps', fvs) ->
 322     returnRn  (ExplicitList exps', fvs)
 323
 324 rnExpr (ExplicitTuple exps)
 325   = addImplicitOccRn (tupleType_name (length exps))     `thenRn_`
 326     rnExprs exps                                        `thenRn` \ (exps', fvExps) ->
 327     returnRn (ExplicitTuple exps', fvExps)
 328
 329 rnExpr (RecordCon (HsVar con) rbinds)
 330   = lookupOccRn con                     `thenRn` \ conname ->
 331     rnRbinds "construction" rbinds      `thenRn` \ (rbinds', fvRbinds) ->
 332     returnRn (RecordCon (HsVar conname) rbinds', fvRbinds)
 333
 334 rnExpr (RecordUpd expr rbinds)
 335   = rnExpr expr                 `thenRn` \ (expr', fvExpr) ->
 336     rnRbinds "update" rbinds    `thenRn` \ (rbinds', fvRbinds) ->
 337     returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
 338
 339 rnExpr (ExprWithTySig expr pty)
 340   = rnExpr expr                                         `thenRn` \ (expr', fvExpr) ->
 341     rnHsSigType (\ sty -> text "an expression") pty     `thenRn` \ pty' ->
 342     returnRn (ExprWithTySig expr' pty', fvExpr)
 343
 344 rnExpr (HsIf p b1 b2 src_loc)
 345   = pushSrcLocRn src_loc $
 346     rnExpr p            `thenRn` \ (p', fvP) ->
 347     rnExpr b1           `thenRn` \ (b1', fvB1) ->
 348     rnExpr b2           `thenRn` \ (b2', fvB2) ->
 349     returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
 350
 351 rnExpr (ArithSeqIn seq)
 352   = lookupImplicitOccRn enumClass_RDR   `thenRn_`
 353     rn_seq seq                          `thenRn` \ (new_seq, fvs) ->
 354     returnRn (ArithSeqIn new_seq, fvs)
 355   where
 356     rn_seq (From expr)
 357      = rnExpr expr      `thenRn` \ (expr', fvExpr) ->
 358        returnRn (From expr', fvExpr)
 359
 360     rn_seq (FromThen expr1 expr2)
 361      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 362        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 363        returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 364
 365     rn_seq (FromTo expr1 expr2)
 366      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 367        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 368        returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 369
 370     rn_seq (FromThenTo expr1 expr2 expr3)
 371      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 372        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 373        rnExpr expr3     `thenRn` \ (expr3', fvExpr3) ->
 374        returnRn (FromThenTo expr1' expr2' expr3',
 375                   unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
 376 \end{code}
 377
 378 %************************************************************************
 379 %*                                                                      *
 380 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 381 %*                                                                      *
 382 %************************************************************************
 383
 384 \begin{code}
 385 rnRbinds str rbinds
 386   = mapRn field_dup_err dup_fields      `thenRn_`
 387     mapAndUnzipRn rn_rbind rbinds       `thenRn` \ (rbinds', fvRbind_s) ->
 388     returnRn (rbinds', unionManyNameSets fvRbind_s)
 389   where
 390     (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
 391
 392     field_dup_err dups = addErrRn (dupFieldErr str dups)
 393
 394     rn_rbind (field, expr, pun)
 395       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 396         rnExpr expr             `thenRn` \ (expr', fvExpr) ->
 397         returnRn ((fieldname, expr', pun), fvExpr)
 398
 399 rnRpats rpats
 400   = mapRn field_dup_err dup_fields      `thenRn_`
 401     mapRn rn_rpat rpats
 402   where
 403     (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
 404
 405     field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
 406
 407     rn_rpat (field, pat, pun)
 408       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 409         rnPat pat               `thenRn` \ pat' ->
 410         returnRn (fieldname, pat', pun)
 411 \end{code}
 412
 413 %************************************************************************
 414 %*                                                                      *
 415 \subsubsection{@Stmt@s: in @do@ expressions}
 416 %*                                                                      *
 417 %************************************************************************
 418
 419 Note that although some bound vars may appear in the free var set for
 420 the first qual, these will eventually be removed by the caller. For
 421 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
 422 @[q <- r, p <- q]@, the free var set for @q <- r@ will
 423 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 424 @r@ will be removed only when we finally return from examining all the
 425 Quals.
 426
 427 \begin{code}
 428 type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 429
 430 rnStmts :: RnExprTy s
 431         -> [RdrNameStmt]
 432         -> ([RenamedStmt] -> RnMS s (a, FreeVars))
 433         -> RnMS s (a, FreeVars)
 434
 435 rnStmts rn_expr [] thing_inside
 436   = thing_inside []
 437
 438 rnStmts rn_expr (stmt:stmts) thing_inside
 439   = rnStmt rn_expr stmt                         $ \ stmt' ->
 440     rnStmts rn_expr stmts                       $ \ stmts' ->
 441     thing_inside (stmt' : stmts')
 442
 443 rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
 444 -- Because of mutual recursion we have to pass in rnExpr.
 445
 446 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
 447   = pushSrcLocRn src_loc $
 448     rn_expr expr                                        `thenRn` \ (expr', fv_expr) ->
 449     bindLocalsRn "pattern in do binding" binders        $ \ new_binders ->
 450     rnPat pat                                           `thenRn` \ pat' ->
 451
 452     thing_inside (BindStmt pat' expr' src_loc)          `thenRn` \ (result, fvs) ->
 453     returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
 454   where
 455     binders = collectPatBinders pat
 456
 457 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
 458   = pushSrcLocRn src_loc $
 459     rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 460     thing_inside (ExprStmt expr' src_loc)       `thenRn` \ (result, fvs) ->
 461     returnRn (result, fv_expr `unionNameSets` fvs)
 462
 463 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
 464   = pushSrcLocRn src_loc $
 465     rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 466     thing_inside (GuardStmt expr' src_loc)      `thenRn` \ (result, fvs) ->
 467     returnRn (result, fv_expr `unionNameSets` fvs)
 468
 469 rnStmt rn_expr (ReturnStmt expr) thing_inside
 470   = rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 471     thing_inside (ReturnStmt expr')             `thenRn` \ (result, fvs) ->
 472     returnRn (result, fv_expr `unionNameSets` fvs)
 473
 474 rnStmt rn_expr (LetStmt binds) thing_inside
 475   = rnBinds binds               $ \ binds' ->
 476     thing_inside (LetStmt binds')
 477 \end{code}
 478
 479 %************************************************************************
 480 %*                                                                      *
 481 \subsubsection{Precedence Parsing}
 482 %*                                                                      *
 483 %************************************************************************
 484
 485 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 486 are assumed to be already correctly arranged.  It needs the fixities
 487 recorded in the OpApp nodes, because fixity info applies to the things
 488 the programmer actually wrote, so you can't find it out from the Name.
 489
 490 Furthermore, the second argument is guaranteed not to be another
 491 operator application.  Why? Because the parser parses all
 492 operator appications left-associatively.
 493
 494 \begin{code}
 495 mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
 496           -> RnMS s RenamedHsExpr
 497
 498 mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
 499           op2 fix2 e2
 500   | nofix_error
 501   = addErrRn (precParseErr (get op1,fix1) (get op2,fix2))       `thenRn_`
 502     returnRn (OpApp e1 op2 fix2 e2)
 503
 504   | rearrange_me
 505   = mkOpAppRn e12 op2 fix2 e2           `thenRn` \ new_e ->
 506     returnRn (OpApp e11 op1 fix1 new_e)
 507   where
 508     (nofix_error, rearrange_me) = compareFixity fix1 fix2
 509
 510 mkOpAppRn e1@(NegApp neg_arg neg_op)
 511           op2
 512           fix2@(Fixity prec2 dir2)
 513           e2
 514   | nofix_error
 515   = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
 516     returnRn (OpApp e1 op2 fix2 e2)
 517
 518   | rearrange_me
 519   = mkOpAppRn neg_arg op2 fix2 e2       `thenRn` \ new_e ->
 520     returnRn (NegApp new_e neg_op)
 521   where
 522     fix_neg = Fixity 6 InfixL   -- Precedence of unary negate is wired in as infixl 6!
 523     (nofix_error, rearrange_me) = compareFixity fix_neg fix2
 524
 525 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 526   = ASSERT( right_op_ok fix e2 )
 527     returnRn (OpApp e1 op fix e2)
 528
 529 get (HsVar n) = n
 530
 531 -- Parser left-associates everything, but
 532 -- derived instances may have correctly-associated things to
 533 -- in the right operarand.  So we just check that the right operand is OK
 534 right_op_ok fix1 (OpApp _ _ fix2 _)
 535   = not error_please && associate_right
 536   where
 537     (error_please, associate_right) = compareFixity fix1 fix2
 538 right_op_ok fix1 other
 539   = True
 540
 541 -- Parser initially makes negation bind more tightly than any other operator
 542 mkNegAppRn neg_arg neg_op
 543   =
 544 #ifdef DEBUG
 545     getModeRn                   `thenRn` \ mode ->
 546     ASSERT( not_op_app mode neg_arg )
 547 #endif
 548     returnRn (NegApp neg_arg neg_op)
 549
 550 not_op_app SourceMode (OpApp _ _ _ _) = False
 551 not_op_app mode other                 = True
 552 \end{code}
 553
 554 \begin{code}
 555 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
 556              -> RnMS s RenamedPat
 557
 558 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
 559              op2 fix2 p2
 560   | nofix_error
 561   = addErrRn (precParseErr (op1,fix1) (op2,fix2))       `thenRn_`
 562     returnRn (ConOpPatIn p1 op2 fix2 p2)
 563
 564   | rearrange_me
 565   = mkConOpPatRn p12 op2 fix2 p2                `thenRn` \ new_p ->
 566     returnRn (ConOpPatIn p11 op1 fix1 new_p)
 567
 568   where
 569     (nofix_error, rearrange_me) = compareFixity fix1 fix2
 570
 571 mkConOpPatRn p1@(NegPatIn neg_arg)
 572           op2
 573           fix2@(Fixity prec2 dir2)
 574           p2
 575   | prec2 > 6   -- Precedence of unary - is wired in as 6!
 576   = addErrRn (precParseNegPatErr (op2,fix2))    `thenRn_`
 577     returnRn (ConOpPatIn p1 op2 fix2 p2)
 578
 579 mkConOpPatRn p1 op fix p2                       -- Default case, no rearrangment
 580   = ASSERT( not_op_pat p2 )
 581     returnRn (ConOpPatIn p1 op fix p2)
 582
 583 not_op_pat (ConOpPatIn _ _ _ _) = False
 584 not_op_pat other                = True
 585 \end{code}
 586
 587 \begin{code}
 588 checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
 589
 590 checkPrecMatch False fn match
 591   = returnRn ()
 592 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
 593   = checkPrec op p1 False       `thenRn_`
 594     checkPrec op p2 True
 595 checkPrecMatch True op _
 596   = panic "checkPrecMatch"
 597
 598 checkPrec op (ConOpPatIn _ op1 _ _) right
 599   = lookupFixity op     `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
 600     lookupFixity op1    `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
 601     let
 602         inf_ok = op1_prec > op_prec ||
 603                  (op1_prec == op_prec &&
 604                   (op1_dir == InfixR && op_dir == InfixR && right ||
 605                    op1_dir == InfixL && op_dir == InfixL && not right))
 606
 607         info  = (op,op_fix)
 608         info1 = (op1,op1_fix)
 609         (infol, infor) = if right then (info, info1) else (info1, info)
 610     in
 611     checkRn inf_ok (precParseErr infol infor)
 612
 613 checkPrec op (NegPatIn _) right
 614   = lookupFixity op     `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
 615     checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
 616
 617 checkPrec op pat right
 618   = returnRn ()
 619 \end{code}
 620
 621 Consider
 622         a `op1` b `op2` c
 623
 624 (compareFixity op1 op2) tells which way to arrange appication, or
 625 whether there's an error.
 626
 627 \begin{code}
 628 compareFixity :: Fixity -> Fixity
 629               -> (Bool,         -- Error please
 630                   Bool)         -- Associate to the right: a op1 (b op2 c)
 631 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
 632   = case prec1 `cmp` prec2 of
 633         GT_ -> left
 634         LT_ -> right
 635         EQ_ -> case (dir1, dir2) of
 636                         (InfixR, InfixR) -> right
 637                         (InfixL, InfixL) -> left
 638                         _                -> error_please
 639   where
 640     right        = (False, True)
 641     left         = (False, False)
 642     error_please = (True,  False)
 643 \end{code}
 644
 645 %************************************************************************
 646 %*                                                                      *
 647 \subsubsection{Literals}
 648 %*                                                                      *
 649 %************************************************************************
 650
 651 When literals occur we have to make sure that the types and classes they involve
 652 are made available.
 653
 654 \begin{code}
 655 litOccurrence (HsChar _)
 656   = addImplicitOccRn charType_name
 657
 658 litOccurrence (HsCharPrim _)
 659   = addImplicitOccRn (getName charPrimTyCon)
 660
 661 litOccurrence (HsString _)
 662   = addImplicitOccRn listType_name      `thenRn_`
 663     addImplicitOccRn charType_name
 664
 665 litOccurrence (HsStringPrim _)
 666   = addImplicitOccRn (getName addrPrimTyCon)
 667
 668 litOccurrence (HsInt _)
 669   = lookupImplicitOccRn numClass_RDR                    -- Int and Integer are forced in by Num
 670
 671 litOccurrence (HsFrac _)
 672   = lookupImplicitOccRn fractionalClass_RDR     `thenRn_`
 673     lookupImplicitOccRn ratioDataCon_RDR
 674         -- We have to make sure that the Ratio type is imported with
 675         -- its constructor, because literals of type Ratio t are
 676         -- built with that constructor.
 677
 678 litOccurrence (HsIntPrim _)
 679   = addImplicitOccRn (getName intPrimTyCon)
 680
 681 litOccurrence (HsFloatPrim _)
 682   = addImplicitOccRn (getName floatPrimTyCon)
 683
 684 litOccurrence (HsDoublePrim _)
 685   = addImplicitOccRn (getName doublePrimTyCon)
 686
 687 litOccurrence (HsLitLit _)
 688   = lookupImplicitOccRn ccallableClass_RDR
 689 \end{code}
 690
 691
 692 %************************************************************************
 693 %*                                                                      *
 694 \subsubsection{Errors}
 695 %*                                                                      *
 696 %************************************************************************
 697
 698 \begin{code}
 699 dupFieldErr str (dup:rest) sty
 700   = hcat [ptext SLIT("duplicate field name `"),
 701                ppr sty dup,
 702                ptext SLIT("' in record "), text str]
 703
 704 negPatErr pat  sty
 705   = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat]
 706
 707 precParseNegPatErr op sty
 708   = hang (ptext SLIT("precedence parsing error"))
 709       4 (hcat [ptext SLIT("prefix `-' has lower precedence than "),
 710                     pp_op sty op,
 711                     ptext SLIT(" in pattern")])
 712
 713 precParseErr op1 op2  sty
 714   = hang (ptext SLIT("precedence parsing error"))
 715       4 (hcat [ptext SLIT("cannot mix "), pp_op sty op1, ptext SLIT(" and "), pp_op sty op2,
 716                     ptext SLIT(" in the same infix expression")])
 717
 718 nonStdGuardErr guard sty
 719   = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
 720       4 (ppr sty guard)
 721
 722 pp_op sty (op, fix) = hcat [ppr sty op, space, parens (ppr sty fix)]
 723 \end{code}