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, rnStmt,
  15         checkPrecMatch
  16    ) where
  17
  18 #include "HsVersions.h"
  19
  20 import {-# SOURCE #-} RnBinds  ( rnBinds )
  21 import {-# SOURCE #-} RnSource ( rnHsTypeFVs )
  22
  23 import HsSyn
  24 import RdrHsSyn
  25 import RnHsSyn
  26 import RnMonad
  27 import RnEnv
  28 import RnHiFiles        ( lookupFixityRn )
  29 import CmdLineOpts      ( DynFlag(..), opt_IgnoreAsserts )
  30 import Literal          ( inIntRange, inCharRange )
  31 import BasicTypes       ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
  32 import PrelNames        ( hasKey, assertIdKey, minusName, negateName, fromIntegerName,
  33                           eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR,
  34                           cCallableClass_RDR, cReturnableClass_RDR,
  35                           monadClass_RDR, enumClass_RDR, ordClass_RDR,
  36                           ratioDataCon_RDR, assertErr_RDR,
  37                           ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR,
  38                           fromInteger_RDR, fromRational_RDR,
  39                         )
  40 import TysPrim          ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
  41                           floatPrimTyCon, doublePrimTyCon
  42                         )
  43 import TysWiredIn       ( intTyCon )
  44 import Name             ( NamedThing(..), mkSysLocalName, nameSrcLoc )
  45 import NameSet
  46 import UniqFM           ( isNullUFM )
  47 import FiniteMap        ( elemFM )
  48 import UniqSet          ( emptyUniqSet )
  49 import List             ( intersectBy )
  50 import ListSetOps       ( unionLists, removeDups )
  51 import Maybes           ( maybeToBool )
  52 import Outputable
  53 \end{code}
  54
  55
  56 *********************************************************
  57 *                                                       *
  58 \subsection{Patterns}
  59 *                                                       *
  60 *********************************************************
  61
  62 \begin{code}
  63 rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars)
  64
  65 rnPat WildPatIn = returnRn (WildPatIn, emptyFVs)
  66
  67 rnPat (VarPatIn name)
  68   = lookupBndrRn  name                  `thenRn` \ vname ->
  69     returnRn (VarPatIn vname, emptyFVs)
  70
  71 rnPat (SigPatIn pat ty)
  72   = doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
  73
  74     if glaExts
  75     then rnPat pat              `thenRn` \ (pat', fvs1) ->
  76          rnHsTypeFVs doc ty     `thenRn` \ (ty',  fvs2) ->
  77          returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
  78
  79     else addErrRn (patSigErr ty)        `thenRn_`
  80          rnPat pat
  81   where
  82     doc = text "a pattern type-signature"
  83
  84 rnPat (LitPatIn s@(HsString _))
  85   = lookupOrigName eqString_RDR         `thenRn` \ eq ->
  86     returnRn (LitPatIn s, unitFV eq)
  87
  88 rnPat (LitPatIn lit)
  89   = litFVs lit          `thenRn` \ fvs ->
  90     returnRn (LitPatIn lit, fvs)
  91
  92 rnPat (NPatIn lit)
  93   = rnOverLit lit                       `thenRn` \ (lit', fvs1) ->
  94     lookupOrigName eqClass_RDR          `thenRn` \ eq   ->      -- Needed to find equality on pattern
  95     returnRn (NPatIn lit', fvs1 `addOneFV` eq)
  96
  97 rnPat (NPlusKPatIn name lit)
  98   = rnOverLit lit                       `thenRn` \ (lit', fvs) ->
  99     lookupOrigName ordClass_RDR         `thenRn` \ ord ->
 100     lookupBndrRn name                   `thenRn` \ name' ->
 101     returnRn (NPlusKPatIn name' lit', fvs `addOneFV` ord `addOneFV` minusName)
 102
 103 rnPat (LazyPatIn pat)
 104   = rnPat pat           `thenRn` \ (pat', fvs) ->
 105     returnRn (LazyPatIn pat', fvs)
 106
 107 rnPat (AsPatIn name pat)
 108   = rnPat pat           `thenRn` \ (pat', fvs) ->
 109     lookupBndrRn name   `thenRn` \ vname ->
 110     returnRn (AsPatIn vname pat', fvs)
 111
 112 rnPat (ConPatIn con pats)
 113   = lookupOccRn con             `thenRn` \ con' ->
 114     mapFvRn rnPat pats          `thenRn` \ (patslist, fvs) ->
 115     returnRn (ConPatIn con' patslist, fvs `addOneFV` con')
 116
 117 rnPat (ConOpPatIn pat1 con _ pat2)
 118   = rnPat pat1          `thenRn` \ (pat1', fvs1) ->
 119     lookupOccRn con     `thenRn` \ con' ->
 120     rnPat pat2          `thenRn` \ (pat2', fvs2) ->
 121
 122     getModeRn           `thenRn` \ mode ->
 123         -- See comments with rnExpr (OpApp ...)
 124     (if isInterfaceMode mode
 125         then returnRn (ConOpPatIn pat1' con' defaultFixity pat2')
 126         else lookupFixityRn con'        `thenRn` \ fixity ->
 127              mkConOpPatRn pat1' con' fixity pat2'
 128     )                                                           `thenRn` \ pat' ->
 129     returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
 130
 131 rnPat (ParPatIn pat)
 132   = rnPat pat           `thenRn` \ (pat', fvs) ->
 133     returnRn (ParPatIn pat', fvs)
 134
 135 rnPat (ListPatIn pats)
 136   = mapFvRn rnPat pats                  `thenRn` \ (patslist, fvs) ->
 137     returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name)
 138
 139 rnPat (TuplePatIn pats boxed)
 140   = mapFvRn rnPat pats                                     `thenRn` \ (patslist, fvs) ->
 141     returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name)
 142   where
 143     tycon_name = tupleTyCon_name boxed (length pats)
 144
 145 rnPat (RecPatIn con rpats)
 146   = lookupOccRn con     `thenRn` \ con' ->
 147     rnRpats rpats       `thenRn` \ (rpats', fvs) ->
 148     returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
 149 rnPat (TypePatIn name) =
 150     (rnHsTypeFVs (text "type pattern") name) `thenRn` \ (name', fvs) ->
 151     returnRn (TypePatIn name', fvs)
 152 \end{code}
 153
 154 ************************************************************************
 155 *                                                                       *
 156 \subsection{Match}
 157 *                                                                       *
 158 ************************************************************************
 159
 160 \begin{code}
 161 rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
 162
 163 rnMatch match@(Match _ pats maybe_rhs_sig grhss)
 164   = pushSrcLocRn (getMatchLoc match)    $
 165
 166         -- Find the universally quantified type variables
 167         -- in the pattern type signatures
 168     getLocalNameEnv                     `thenRn` \ name_env ->
 169     let
 170         tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
 171         rhs_sig_tyvars = case maybe_rhs_sig of
 172                                 Nothing -> []
 173                                 Just ty -> extractHsTyRdrTyVars ty
 174         tyvars_in_pats = extractPatsTyVars pats
 175         forall_tyvars  = filter (not . (`elemFM` name_env)) tyvars_in_sigs
 176         doc_sig        = text "a pattern type-signature"
 177         doc_pats       = text "a pattern match"
 178     in
 179     bindNakedTyVarsFVRn doc_sig 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_pats (collectPatsBinders pats) $ \ new_binders ->
 185
 186     mapFvRn rnPat pats                  `thenRn` \ (pats', pat_fvs) ->
 187     rnGRHSs grhss                       `thenRn` \ (grhss', grhss_fvs) ->
 188     doptRn Opt_GlasgowExts              `thenRn` \ opt_GlasgowExts ->
 189     (case maybe_rhs_sig of
 190         Nothing -> returnRn (Nothing, emptyFVs)
 191         Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty     `thenRn` \ (ty', ty_fvs) ->
 192                                      returnRn (Just ty', ty_fvs)
 193                 | otherwise       -> addErrRn (patSigErr ty)    `thenRn_`
 194                                      returnRn (Nothing, emptyFVs)
 195     )                                   `thenRn` \ (maybe_rhs_sig', ty_fvs) ->
 196
 197     let
 198         binder_set     = mkNameSet new_binders
 199         unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
 200         all_fvs        = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs
 201     in
 202     warnUnusedMatches unused_binders            `thenRn_`
 203
 204     returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
 205         -- The bindLocals and bindTyVars will remove the bound FVs
 206 \end{code}
 207
 208 %************************************************************************
 209 %*                                                                      *
 210 \subsubsection{Guarded right-hand sides (GRHSs)}
 211 %*                                                                      *
 212 %************************************************************************
 213
 214 \begin{code}
 215 rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars)
 216
 217 rnGRHSs (GRHSs grhss binds maybe_ty)
 218   = ASSERT( not (maybeToBool maybe_ty) )
 219     rnBinds binds               $ \ binds' ->
 220     mapFvRn rnGRHS grhss        `thenRn` \ (grhss', fvGRHSs) ->
 221     returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
 222
 223 rnGRHS (GRHS guarded locn)
 224   = doptRn Opt_GlasgowExts              `thenRn` \ opt_GlasgowExts ->
 225     pushSrcLocRn locn $
 226     (if not (opt_GlasgowExts || is_standard_guard guarded) then
 227                 addWarnRn (nonStdGuardErr guarded)
 228      else
 229                 returnRn ()
 230     )           `thenRn_`
 231
 232     rnStmts guarded     `thenRn` \ ((_, guarded'), fvs) ->
 233     returnRn (GRHS guarded' locn, fvs)
 234   where
 235         -- Standard Haskell 1.4 guards are just a single boolean
 236         -- expression, rather than a list of qualifiers as in the
 237         -- Glasgow extension
 238     is_standard_guard [ResultStmt _ _]               = True
 239     is_standard_guard [ExprStmt _ _, ResultStmt _ _] = True
 240     is_standard_guard other                          = False
 241 \end{code}
 242
 243 %************************************************************************
 244 %*                                                                      *
 245 \subsubsection{Expressions}
 246 %*                                                                      *
 247 %************************************************************************
 248
 249 \begin{code}
 250 rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars)
 251 rnExprs ls = rnExprs' ls emptyUniqSet
 252  where
 253   rnExprs' [] acc = returnRn ([], acc)
 254   rnExprs' (expr:exprs) acc
 255    = rnExpr expr                `thenRn` \ (expr', fvExpr) ->
 256
 257         -- Now we do a "seq" on the free vars because typically it's small
 258         -- or empty, especially in very long lists of constants
 259     let
 260         acc' = acc `plusFV` fvExpr
 261     in
 262     (grubby_seqNameSet acc' rnExprs') exprs acc'        `thenRn` \ (exprs', fvExprs) ->
 263     returnRn (expr':exprs', fvExprs)
 264
 265 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
 266 grubby_seqNameSet ns result | isNullUFM ns = result
 267                             | otherwise    = result
 268 \end{code}
 269
 270 Variables. We look up the variable and return the resulting name.
 271
 272 \begin{code}
 273 rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
 274
 275 rnExpr (HsVar v)
 276   = lookupOccRn v       `thenRn` \ name ->
 277     if name `hasKey` assertIdKey then
 278         -- We expand it to (GHCerr.assert__ location)
 279         mkAssertExpr
 280     else
 281         -- The normal case
 282        returnRn (HsVar name, unitFV name)
 283
 284 rnExpr (HsIPVar v)
 285   = newIPName v                 `thenRn` \ name ->
 286     returnRn (HsIPVar name, emptyFVs)
 287
 288 rnExpr (HsLit lit)
 289   = litFVs lit          `thenRn` \ fvs ->
 290     returnRn (HsLit lit, fvs)
 291
 292 rnExpr (HsOverLit lit)
 293   = rnOverLit lit               `thenRn` \ (lit', fvs) ->
 294     returnRn (HsOverLit lit', fvs)
 295
 296 rnExpr (HsLam match)
 297   = rnMatch match       `thenRn` \ (match', fvMatch) ->
 298     returnRn (HsLam match', fvMatch)
 299
 300 rnExpr (HsApp fun arg)
 301   = rnExpr fun          `thenRn` \ (fun',fvFun) ->
 302     rnExpr arg          `thenRn` \ (arg',fvArg) ->
 303     returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
 304
 305 rnExpr (OpApp e1 op _ e2)
 306   = rnExpr e1                           `thenRn` \ (e1', fv_e1) ->
 307     rnExpr e2                           `thenRn` \ (e2', fv_e2) ->
 308     rnExpr op                           `thenRn` \ (op'@(HsVar op_name), fv_op) ->
 309
 310         -- Deal with fixity
 311         -- When renaming code synthesised from "deriving" declarations
 312         -- we're in Interface mode, and we should ignore fixity; assume
 313         -- that the deriving code generator got the association correct
 314         -- Don't even look up the fixity when in interface mode
 315     getModeRn                           `thenRn` \ mode ->
 316     (if isInterfaceMode mode
 317         then returnRn (OpApp e1' op' defaultFixity e2')
 318         else lookupFixityRn op_name             `thenRn` \ fixity ->
 319              mkOpAppRn e1' op' fixity e2'
 320     )                                   `thenRn` \ final_e ->
 321
 322     returnRn (final_e,
 323               fv_e1 `plusFV` fv_op `plusFV` fv_e2)
 324
 325 rnExpr (NegApp e)
 326   = rnExpr e                    `thenRn` \ (e', fv_e) ->
 327     mkNegAppRn e'               `thenRn` \ final_e ->
 328     returnRn (final_e, fv_e `addOneFV` negateName)
 329
 330 rnExpr (HsPar e)
 331   = rnExpr e            `thenRn` \ (e', fvs_e) ->
 332     returnRn (HsPar e', fvs_e)
 333
 334 rnExpr section@(SectionL expr op)
 335   = rnExpr expr                                 `thenRn` \ (expr', fvs_expr) ->
 336     rnExpr op                                   `thenRn` \ (op', fvs_op) ->
 337     checkSectionPrec "left" section op' expr'   `thenRn_`
 338     returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
 339
 340 rnExpr section@(SectionR op expr)
 341   = rnExpr op                                   `thenRn` \ (op',   fvs_op) ->
 342     rnExpr expr                                 `thenRn` \ (expr', fvs_expr) ->
 343     checkSectionPrec "right" section op' expr'  `thenRn_`
 344     returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
 345
 346 rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
 347         -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
 348   = lookupOrigNames [cCallableClass_RDR,
 349                           cReturnableClass_RDR,
 350                           ioDataCon_RDR]        `thenRn` \ implicit_fvs ->
 351     rnExprs args                                `thenRn` \ (args', fvs_args) ->
 352     returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
 353               fvs_args `plusFV` implicit_fvs)
 354
 355 rnExpr (HsSCC lbl expr)
 356   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 357     returnRn (HsSCC lbl expr', fvs_expr)
 358
 359 rnExpr (HsCase expr ms src_loc)
 360   = pushSrcLocRn src_loc $
 361     rnExpr expr                 `thenRn` \ (new_expr, e_fvs) ->
 362     mapFvRn rnMatch ms          `thenRn` \ (new_ms, ms_fvs) ->
 363     returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
 364
 365 rnExpr (HsLet binds expr)
 366   = rnBinds binds               $ \ binds' ->
 367     rnExpr expr                  `thenRn` \ (expr',fvExpr) ->
 368     returnRn (HsLet binds' expr', fvExpr)
 369
 370 rnExpr (HsWith expr binds)
 371   = rnExpr expr                 `thenRn` \ (expr',fvExpr) ->
 372     rnIPBinds binds             `thenRn` \ (binds',fvBinds) ->
 373     returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
 374
 375 rnExpr e@(HsDo do_or_lc stmts src_loc)
 376   = pushSrcLocRn src_loc $
 377     lookupOrigNames implicit_rdr_names  `thenRn` \ implicit_fvs ->
 378     rnStmts stmts                       `thenRn` \ ((_, stmts'), fvs) ->
 379         -- check the statement list ends in an expression
 380     case last stmts' of {
 381         ResultStmt _ _ -> returnRn () ;
 382         _              -> addErrRn (doStmtListErr e)
 383     }                                   `thenRn_`
 384     returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
 385   where
 386     implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
 387         -- Monad stuff should not be necessary for a list comprehension
 388         -- but the typechecker looks up the bind and return Ids anyway
 389         -- Oh well.
 390
 391
 392 rnExpr (ExplicitList exps)
 393   = rnExprs exps                        `thenRn` \ (exps', fvs) ->
 394     returnRn  (ExplicitList exps', fvs `addOneFV` listTyCon_name)
 395
 396 rnExpr (ExplicitTuple exps boxity)
 397   = rnExprs exps                                `thenRn` \ (exps', fvs) ->
 398     returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
 399   where
 400     tycon_name = tupleTyCon_name boxity (length exps)
 401
 402 rnExpr (RecordCon con_id rbinds)
 403   = lookupOccRn con_id                  `thenRn` \ conname ->
 404     rnRbinds "construction" rbinds      `thenRn` \ (rbinds', fvRbinds) ->
 405     returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
 406
 407 rnExpr (RecordUpd expr rbinds)
 408   = rnExpr expr                 `thenRn` \ (expr', fvExpr) ->
 409     rnRbinds "update" rbinds    `thenRn` \ (rbinds', fvRbinds) ->
 410     returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
 411
 412 rnExpr (ExprWithTySig expr pty)
 413   = rnExpr expr                                            `thenRn` \ (expr', fvExpr) ->
 414     rnHsTypeFVs (text "an expression type signature") pty  `thenRn` \ (pty', fvTy) ->
 415     returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
 416
 417 rnExpr (HsIf p b1 b2 src_loc)
 418   = pushSrcLocRn src_loc $
 419     rnExpr p            `thenRn` \ (p', fvP) ->
 420     rnExpr b1           `thenRn` \ (b1', fvB1) ->
 421     rnExpr b2           `thenRn` \ (b2', fvB2) ->
 422     returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
 423
 424 rnExpr (HsType a)
 425   = rnHsTypeFVs doc a   `thenRn` \ (t, fvT) ->
 426     returnRn (HsType t, fvT)
 427   where
 428     doc = text "renaming a type pattern"
 429
 430 rnExpr (ArithSeqIn seq)
 431   = lookupOrigName enumClass_RDR        `thenRn` \ enum ->
 432     rn_seq seq                          `thenRn` \ (new_seq, fvs) ->
 433     returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
 434   where
 435     rn_seq (From expr)
 436      = rnExpr expr      `thenRn` \ (expr', fvExpr) ->
 437        returnRn (From expr', fvExpr)
 438
 439     rn_seq (FromThen expr1 expr2)
 440      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 441        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 442        returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 443
 444     rn_seq (FromTo expr1 expr2)
 445      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 446        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 447        returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 448
 449     rn_seq (FromThenTo expr1 expr2 expr3)
 450      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 451        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 452        rnExpr expr3     `thenRn` \ (expr3', fvExpr3) ->
 453        returnRn (FromThenTo expr1' expr2' expr3',
 454                   plusFVs [fvExpr1, fvExpr2, fvExpr3])
 455 \end{code}
 456
 457 These three are pattern syntax appearing in expressions.
 458 Since all the symbols are reservedops we can simply reject them.
 459 We return a (bogus) EWildPat in each case.
 460
 461 \begin{code}
 462 rnExpr e@EWildPat = addErrRn (patSynErr e)      `thenRn_`
 463                     returnRn (EWildPat, emptyFVs)
 464
 465 rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e)  `thenRn_`
 466                         returnRn (EWildPat, emptyFVs)
 467
 468 rnExpr e@(ELazyPat _) = addErrRn (patSynErr e)  `thenRn_`
 469                         returnRn (EWildPat, emptyFVs)
 470 \end{code}
 471
 472
 473
 474 %************************************************************************
 475 %*                                                                      *
 476 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 477 %*                                                                      *
 478 %************************************************************************
 479
 480 \begin{code}
 481 rnRbinds str rbinds
 482   = mapRn_ field_dup_err dup_fields     `thenRn_`
 483     mapFvRn rn_rbind rbinds             `thenRn` \ (rbinds', fvRbind) ->
 484     returnRn (rbinds', fvRbind)
 485   where
 486     (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
 487
 488     field_dup_err dups = addErrRn (dupFieldErr str dups)
 489
 490     rn_rbind (field, expr, pun)
 491       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 492         rnExpr expr             `thenRn` \ (expr', fvExpr) ->
 493         returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
 494
 495 rnRpats rpats
 496   = mapRn_ field_dup_err dup_fields     `thenRn_`
 497     mapFvRn rn_rpat rpats               `thenRn` \ (rpats', fvs) ->
 498     returnRn (rpats', fvs)
 499   where
 500     (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
 501
 502     field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
 503
 504     rn_rpat (field, pat, pun)
 505       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 506         rnPat pat               `thenRn` \ (pat', fvs) ->
 507         returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
 508 \end{code}
 509
 510 %************************************************************************
 511 %*                                                                      *
 512 \subsubsection{@rnIPBinds@s: in implicit parameter bindings}            *
 513 %*                                                                      *
 514 %************************************************************************
 515
 516 \begin{code}
 517 rnIPBinds [] = returnRn ([], emptyFVs)
 518 rnIPBinds ((n, expr) : binds)
 519   = newIPName n                 `thenRn` \ name ->
 520     rnExpr expr                 `thenRn` \ (expr',fvExpr) ->
 521     rnIPBinds binds             `thenRn` \ (binds',fvBinds) ->
 522     returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
 523
 524 \end{code}
 525
 526 %************************************************************************
 527 %*                                                                      *
 528 \subsubsection{@Stmt@s: in @do@ expressions}
 529 %*                                                                      *
 530 %************************************************************************
 531
 532 Note that although some bound vars may appear in the free var set for
 533 the first qual, these will eventually be removed by the caller. For
 534 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
 535 @[q <- r, p <- q]@, the free var set for @q <- r@ will
 536 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 537 @r@ will be removed only when we finally return from examining all the
 538 Quals.
 539
 540 \begin{code}
 541 rnStmts :: [RdrNameStmt]
 542         -> RnMS (([Name], [RenamedStmt]), FreeVars)
 543
 544 rnStmts []
 545   = returnRn (([], []), emptyFVs)
 546
 547 rnStmts (stmt:stmts)
 548   = getLocalNameEnv             `thenRn` \ name_env ->
 549     rnStmt stmt                         $ \ stmt' ->
 550     rnStmts stmts                       `thenRn` \ ((binders, stmts'), fvs) ->
 551     returnRn ((binders, stmt' : stmts'), fvs)
 552
 553 rnStmt :: RdrNameStmt
 554        -> (RenamedStmt -> RnMS (([Name], a), FreeVars))
 555        -> RnMS (([Name], a), FreeVars)
 556 -- The thing list of names returned is the list returned by the
 557 -- thing_inside, plus the binders of the arguments stmt
 558
 559 -- Because of mutual recursion we have to pass in rnExpr.
 560
 561 rnStmt (ParStmt stmtss) thing_inside
 562   = mapFvRn rnStmts stmtss              `thenRn` \ (bndrstmtss, fv_stmtss) ->
 563     let binderss = map fst bndrstmtss
 564         checkBndrs all_bndrs bndrs
 565           = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_`
 566             returnRn (bndrs ++ all_bndrs)
 567         eqOcc n1 n2 = nameOccName n1 == nameOccName n2
 568         err = text "duplicate binding in parallel list comprehension"
 569     in
 570     foldlRn checkBndrs [] binderss      `thenRn` \ new_binders ->
 571     bindLocalNamesFV new_binders        $
 572     thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) ->
 573     returnRn ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest)
 574
 575 rnStmt (BindStmt pat expr src_loc) thing_inside
 576   = pushSrcLocRn src_loc $
 577     rnExpr expr                                 `thenRn` \ (expr', fv_expr) ->
 578     bindLocalsFVRn doc binders                  $ \ new_binders ->
 579     rnPat pat                                   `thenRn` \ (pat', fv_pat) ->
 580     thing_inside (BindStmt pat' expr' src_loc)  `thenRn` \ ((rest_binders, result), fvs) ->
 581     -- ZZ is shadowing handled correctly?
 582     returnRn ((new_binders ++ rest_binders, result),
 583               fv_expr `plusFV` fvs `plusFV` fv_pat)
 584   where
 585     binders = collectPatBinders pat
 586     doc = text "a pattern in do binding"
 587
 588 rnStmt (ExprStmt expr src_loc) thing_inside
 589   = pushSrcLocRn src_loc $
 590     rnExpr expr                                 `thenRn` \ (expr', fv_expr) ->
 591     thing_inside (ExprStmt expr' src_loc)       `thenRn` \ (result, fvs) ->
 592     returnRn (result, fv_expr `plusFV` fvs)
 593
 594 rnStmt (ResultStmt expr src_loc) thing_inside
 595   = pushSrcLocRn src_loc $
 596     rnExpr expr                                 `thenRn` \ (expr', fv_expr) ->
 597     thing_inside (ResultStmt expr' src_loc)     `thenRn` \ (result, fvs) ->
 598     returnRn (result, fv_expr `plusFV` fvs)
 599
 600 rnStmt (LetStmt binds) thing_inside
 601   = rnBinds binds                               $ \ binds' ->
 602     let new_binders = collectHsBinders binds' in
 603     thing_inside (LetStmt binds')    `thenRn` \ ((rest_binders, result), fvs) ->
 604     returnRn ((new_binders ++ rest_binders, result), fvs )
 605 \end{code}
 606
 607 %************************************************************************
 608 %*                                                                      *
 609 \subsubsection{Precedence Parsing}
 610 %*                                                                      *
 611 %************************************************************************
 612
 613 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 614 are assumed to be already correctly arranged.  It needs the fixities
 615 recorded in the OpApp nodes, because fixity info applies to the things
 616 the programmer actually wrote, so you can't find it out from the Name.
 617
 618 Furthermore, the second argument is guaranteed not to be another
 619 operator application.  Why? Because the parser parses all
 620 operator appications left-associatively, EXCEPT negation, which
 621 we need to handle specially.
 622
 623 \begin{code}
 624 mkOpAppRn :: RenamedHsExpr                      -- Left operand; already rearranged
 625           -> RenamedHsExpr -> Fixity            -- Operator and fixity
 626           -> RenamedHsExpr                      -- Right operand (not an OpApp, but might
 627                                                 -- be a NegApp)
 628           -> RnMS RenamedHsExpr
 629
 630 ---------------------------
 631 -- (e11 `op1` e12) `op2` e2
 632 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
 633   | nofix_error
 634   = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
 635     returnRn (OpApp e1 op2 fix2 e2)
 636
 637   | associate_right
 638   = mkOpAppRn e12 op2 fix2 e2           `thenRn` \ new_e ->
 639     returnRn (OpApp e11 op1 fix1 new_e)
 640   where
 641     (nofix_error, associate_right) = compareFixity fix1 fix2
 642
 643 ---------------------------
 644 --      (- neg_arg) `op` e2
 645 mkOpAppRn e1@(NegApp neg_arg) op2 fix2 e2
 646   | nofix_error
 647   = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))    `thenRn_`
 648     returnRn (OpApp e1 op2 fix2 e2)
 649
 650   | associate_right
 651   = mkOpAppRn neg_arg op2 fix2 e2       `thenRn` \ new_e ->
 652     returnRn (NegApp new_e)
 653   where
 654     (nofix_error, associate_right) = compareFixity negateFixity fix2
 655
 656 ---------------------------
 657 --      e1 `op` - neg_arg
 658 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg)       -- NegApp can occur on the right
 659   | not associate_right                                 -- We *want* right association
 660   = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))  `thenRn_`
 661     returnRn (OpApp e1 op1 fix1 e2)
 662   where
 663     (_, associate_right) = compareFixity fix1 negateFixity
 664
 665 ---------------------------
 666 --      Default case
 667 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 668   = ASSERT2( right_op_ok fix e2,
 669              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
 670     )
 671     returnRn (OpApp e1 op fix e2)
 672
 673 -- Parser left-associates everything, but
 674 -- derived instances may have correctly-associated things to
 675 -- in the right operarand.  So we just check that the right operand is OK
 676 right_op_ok fix1 (OpApp _ _ fix2 _)
 677   = not error_please && associate_right
 678   where
 679     (error_please, associate_right) = compareFixity fix1 fix2
 680 right_op_ok fix1 other
 681   = True
 682
 683 -- Parser initially makes negation bind more tightly than any other operator
 684 mkNegAppRn neg_arg
 685   =
 686 #ifdef DEBUG
 687     getModeRn                   `thenRn` \ mode ->
 688     ASSERT( not_op_app mode neg_arg )
 689 #endif
 690     returnRn (NegApp neg_arg)
 691
 692 not_op_app SourceMode (OpApp _ _ _ _) = False
 693 not_op_app mode other                 = True
 694 \end{code}
 695
 696 \begin{code}
 697 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
 698              -> RnMS RenamedPat
 699
 700 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
 701              op2 fix2 p2
 702   | nofix_error
 703   = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
 704     returnRn (ConOpPatIn p1 op2 fix2 p2)
 705
 706   | associate_right
 707   = mkConOpPatRn p12 op2 fix2 p2                `thenRn` \ new_p ->
 708     returnRn (ConOpPatIn p11 op1 fix1 new_p)
 709
 710   where
 711     (nofix_error, associate_right) = compareFixity fix1 fix2
 712
 713 mkConOpPatRn p1 op fix p2                       -- Default case, no rearrangment
 714   = ASSERT( not_op_pat p2 )
 715     returnRn (ConOpPatIn p1 op fix p2)
 716
 717 not_op_pat (ConOpPatIn _ _ _ _) = False
 718 not_op_pat other                = True
 719 \end{code}
 720
 721 \begin{code}
 722 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
 723
 724 checkPrecMatch False fn match
 725   = returnRn ()
 726
 727 checkPrecMatch True op (Match _ (p1:p2:_) _ _)
 728         -- True indicates an infix lhs
 729   = getModeRn           `thenRn` \ mode ->
 730         -- See comments with rnExpr (OpApp ...)
 731     if isInterfaceMode mode
 732         then returnRn ()
 733         else checkPrec op p1 False      `thenRn_`
 734              checkPrec op p2 True
 735
 736 checkPrecMatch True op _ = panic "checkPrecMatch"
 737
 738 checkPrec op (ConOpPatIn _ op1 _ _) right
 739   = lookupFixityRn op   `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
 740     lookupFixityRn op1  `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
 741     let
 742         inf_ok = op1_prec > op_prec ||
 743                  (op1_prec == op_prec &&
 744                   (op1_dir == InfixR && op_dir == InfixR && right ||
 745                    op1_dir == InfixL && op_dir == InfixL && not right))
 746
 747         info  = (ppr_op op,  op_fix)
 748         info1 = (ppr_op op1, op1_fix)
 749         (infol, infor) = if right then (info, info1) else (info1, info)
 750     in
 751     checkRn inf_ok (precParseErr infol infor)
 752
 753 checkPrec op pat right
 754   = returnRn ()
 755
 756 -- Check precedence of (arg op) or (op arg) respectively
 757 -- If arg is itself an operator application, its precedence should
 758 -- be higher than that of op
 759 checkSectionPrec left_or_right section op arg
 760   = case arg of
 761         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
 762         NegApp _         -> go_for_it pp_prefix_minus negateFixity
 763         other            -> returnRn ()
 764   where
 765     HsVar op_name = op
 766     go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
 767         = lookupFixityRn op_name        `thenRn` \ op_fix@(Fixity op_prec _) ->
 768           checkRn (op_prec < arg_prec)
 769                   (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
 770 \end{code}
 771
 772 Consider
 773 \begin{verbatim}
 774         a `op1` b `op2` c
 775 \end{verbatim}
 776 @(compareFixity op1 op2)@ tells which way to arrange appication, or
 777 whether there's an error.
 778
 779 \begin{code}
 780 compareFixity :: Fixity -> Fixity
 781               -> (Bool,         -- Error please
 782                   Bool)         -- Associate to the right: a op1 (b op2 c)
 783 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
 784   = case prec1 `compare` prec2 of
 785         GT -> left
 786         LT -> right
 787         EQ -> case (dir1, dir2) of
 788                         (InfixR, InfixR) -> right
 789                         (InfixL, InfixL) -> left
 790                         _                -> error_please
 791   where
 792     right        = (False, True)
 793     left         = (False, False)
 794     error_please = (True,  False)
 795 \end{code}
 796
 797 %************************************************************************
 798 %*                                                                      *
 799 \subsubsection{Literals}
 800 %*                                                                      *
 801 %************************************************************************
 802
 803 When literals occur we have to make sure
 804 that the types and classes they involve
 805 are made available.
 806
 807 \begin{code}
 808 litFVs (HsChar c)
 809    = checkRn (inCharRange c) (bogusCharError c) `thenRn_`
 810      returnRn (unitFV charTyCon_name)
 811
 812 litFVs (HsCharPrim c)         = returnRn (unitFV (getName charPrimTyCon))
 813 litFVs (HsString s)           = returnRn (mkFVs [listTyCon_name, charTyCon_name])
 814 litFVs (HsStringPrim s)       = returnRn (unitFV (getName addrPrimTyCon))
 815 litFVs (HsInt i)              = returnRn (unitFV (getName intTyCon))
 816 litFVs (HsIntPrim i)          = returnRn (unitFV (getName intPrimTyCon))
 817 litFVs (HsFloatPrim f)        = returnRn (unitFV (getName floatPrimTyCon))
 818 litFVs (HsDoublePrim d)       = returnRn (unitFV (getName doublePrimTyCon))
 819 litFVs (HsLitLit l bogus_ty)  = lookupOrigName cCallableClass_RDR       `thenRn` \ cc ->
 820                                 returnRn (unitFV cc)
 821 litFVs lit                    = pprPanic "RnExpr.litFVs" (ppr lit)      -- HsInteger and HsRat only appear
 822                                                                         -- in post-typechecker translations
 823
 824 rnOverLit (HsIntegral i)
 825   | inIntRange i
 826   = returnRn (HsIntegral i, unitFV fromIntegerName)
 827   | otherwise
 828   = lookupOrigNames [fromInteger_RDR, plusInteger_RDR, timesInteger_RDR]        `thenRn` \ ns ->
 829         -- Big integers are built, using + and *, out of small integers
 830         -- [No particular reason why we use fromIntegerName in one case can
 831         --  fromInteger_RDR in the other; but plusInteger_RDR means we
 832         --  can get away without plusIntegerName altogether.]
 833     returnRn (HsIntegral i, ns)
 834
 835 rnOverLit (HsFractional i)
 836   = lookupOrigNames [fromRational_RDR, ratioDataCon_RDR,
 837                      plusInteger_RDR, timesInteger_RDR]  `thenRn` \ ns ->
 838         -- We have to make sure that the Ratio type is imported with
 839         -- its constructor, because literals of type Ratio t are
 840         -- built with that constructor.
 841         -- The Rational type is needed too, but that will come in
 842         -- when fractionalClass does.
 843         -- The plus/times integer operations may be needed to construct the numerator
 844         -- and denominator (see DsUtils.mkIntegerLit)
 845     returnRn (HsFractional i, ns)
 846 \end{code}
 847
 848 %************************************************************************
 849 %*                                                                      *
 850 \subsubsection{Assertion utils}
 851 %*                                                                      *
 852 %************************************************************************
 853
 854 \begin{code}
 855 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
 856 mkAssertExpr =
 857   lookupOrigName assertErr_RDR          `thenRn` \ name ->
 858   getSrcLocRn                           `thenRn` \ sloc ->
 859
 860     -- if we're ignoring asserts, return (\ _ e -> e)
 861     -- if not, return (assertError "src-loc")
 862
 863   if opt_IgnoreAsserts then
 864     getUniqRn                           `thenRn` \ uniq ->
 865     let
 866      vname = mkSysLocalName uniq SLIT("v")
 867      expr  = HsLam ignorePredMatch
 868      loc   = nameSrcLoc vname
 869      ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) Nothing loc
 870     in
 871     returnRn (expr, unitFV name)
 872   else
 873     let
 874      expr =
 875           HsApp (HsVar name)
 876                 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
 877
 878     in
 879     returnRn (expr, unitFV name)
 880
 881 \end{code}
 882
 883 %************************************************************************
 884 %*                                                                      *
 885 \subsubsection{Errors}
 886 %*                                                                      *
 887 %************************************************************************
 888
 889 \begin{code}
 890 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
 891 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
 892 pp_prefix_minus = ptext SLIT("prefix `-'")
 893
 894 dupFieldErr str (dup:rest)
 895   = hsep [ptext SLIT("duplicate field name"),
 896           quotes (ppr dup),
 897           ptext SLIT("in record"), text str]
 898
 899 precParseErr op1 op2
 900   = hang (ptext SLIT("precedence parsing error"))
 901       4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
 902                ppr_opfix op2,
 903                ptext SLIT("in the same infix expression")])
 904
 905 sectionPrecErr op arg_op section
 906  = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
 907          nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
 908          nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]
 909
 910 nonStdGuardErr guard
 911   = hang (ptext
 912     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
 913     ) 4 (ppr guard)
 914
 915 patSigErr ty
 916   =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
 917         $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
 918
 919 patSynErr e
 920   = sep [ptext SLIT("Pattern syntax in expression context:"),
 921          nest 4 (ppr e)]
 922
 923 doStmtListErr e
 924   = sep [ptext SLIT("`do' statements must end in expression:"),
 925          nest 4 (ppr e)]
 926
 927 bogusCharError c
 928   = ptext SLIT("character literal out of range: '\\") <> int c <> char '\''
 929 \end{code}