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