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