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