ghc/compiler/rename/RnExpr.lhs

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