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