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 [ExprStmt _ _]               = True
 239     is_standard_guard [ExprStmt _ _, ExprStmt _ _] = 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         ExprStmt _ _ -> 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 (LetStmt binds) thing_inside
 595   = rnBinds binds                               $ \ binds' ->
 596     let new_binders = collectHsBinders binds' in
 597     thing_inside (LetStmt binds')    `thenRn` \ ((rest_binders, result), fvs) ->
 598     returnRn ((new_binders ++ rest_binders, result), fvs )
 599 \end{code}
 600
 601 %************************************************************************
 602 %*                                                                      *
 603 \subsubsection{Precedence Parsing}
 604 %*                                                                      *
 605 %************************************************************************
 606
 607 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 608 are assumed to be already correctly arranged.  It needs the fixities
 609 recorded in the OpApp nodes, because fixity info applies to the things
 610 the programmer actually wrote, so you can't find it out from the Name.
 611
 612 Furthermore, the second argument is guaranteed not to be another
 613 operator application.  Why? Because the parser parses all
 614 operator appications left-associatively, EXCEPT negation, which
 615 we need to handle specially.
 616
 617 \begin{code}
 618 mkOpAppRn :: RenamedHsExpr                      -- Left operand; already rearranged
 619           -> RenamedHsExpr -> Fixity            -- Operator and fixity
 620           -> RenamedHsExpr                      -- Right operand (not an OpApp, but might
 621                                                 -- be a NegApp)
 622           -> RnMS RenamedHsExpr
 623
 624 ---------------------------
 625 -- (e11 `op1` e12) `op2` e2
 626 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
 627   | nofix_error
 628   = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
 629     returnRn (OpApp e1 op2 fix2 e2)
 630
 631   | associate_right
 632   = mkOpAppRn e12 op2 fix2 e2           `thenRn` \ new_e ->
 633     returnRn (OpApp e11 op1 fix1 new_e)
 634   where
 635     (nofix_error, associate_right) = compareFixity fix1 fix2
 636
 637 ---------------------------
 638 --      (- neg_arg) `op` e2
 639 mkOpAppRn e1@(NegApp neg_arg) op2 fix2 e2
 640   | nofix_error
 641   = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))    `thenRn_`
 642     returnRn (OpApp e1 op2 fix2 e2)
 643
 644   | associate_right
 645   = mkOpAppRn neg_arg op2 fix2 e2       `thenRn` \ new_e ->
 646     returnRn (NegApp new_e)
 647   where
 648     (nofix_error, associate_right) = compareFixity negateFixity fix2
 649
 650 ---------------------------
 651 --      e1 `op` - neg_arg
 652 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg)       -- NegApp can occur on the right
 653   | not associate_right                                 -- We *want* right association
 654   = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))  `thenRn_`
 655     returnRn (OpApp e1 op1 fix1 e2)
 656   where
 657     (_, associate_right) = compareFixity fix1 negateFixity
 658
 659 ---------------------------
 660 --      Default case
 661 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 662   = ASSERT2( right_op_ok fix e2,
 663              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
 664     )
 665     returnRn (OpApp e1 op fix e2)
 666
 667 -- Parser left-associates everything, but
 668 -- derived instances may have correctly-associated things to
 669 -- in the right operarand.  So we just check that the right operand is OK
 670 right_op_ok fix1 (OpApp _ _ fix2 _)
 671   = not error_please && associate_right
 672   where
 673     (error_please, associate_right) = compareFixity fix1 fix2
 674 right_op_ok fix1 other
 675   = True
 676
 677 -- Parser initially makes negation bind more tightly than any other operator
 678 mkNegAppRn neg_arg
 679   =
 680 #ifdef DEBUG
 681     getModeRn                   `thenRn` \ mode ->
 682     ASSERT( not_op_app mode neg_arg )
 683 #endif
 684     returnRn (NegApp neg_arg)
 685
 686 not_op_app SourceMode (OpApp _ _ _ _) = False
 687 not_op_app mode other                 = True
 688 \end{code}
 689
 690 \begin{code}
 691 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
 692              -> RnMS RenamedPat
 693
 694 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
 695              op2 fix2 p2
 696   | nofix_error
 697   = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
 698     returnRn (ConOpPatIn p1 op2 fix2 p2)
 699
 700   | associate_right
 701   = mkConOpPatRn p12 op2 fix2 p2                `thenRn` \ new_p ->
 702     returnRn (ConOpPatIn p11 op1 fix1 new_p)
 703
 704   where
 705     (nofix_error, associate_right) = compareFixity fix1 fix2
 706
 707 mkConOpPatRn p1 op fix p2                       -- Default case, no rearrangment
 708   = ASSERT( not_op_pat p2 )
 709     returnRn (ConOpPatIn p1 op fix p2)
 710
 711 not_op_pat (ConOpPatIn _ _ _ _) = False
 712 not_op_pat other                = True
 713 \end{code}
 714
 715 \begin{code}
 716 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
 717
 718 checkPrecMatch False fn match
 719   = returnRn ()
 720
 721 checkPrecMatch True op (Match _ (p1:p2:_) _ _)
 722         -- True indicates an infix lhs
 723   = getModeRn           `thenRn` \ mode ->
 724         -- See comments with rnExpr (OpApp ...)
 725     if isInterfaceMode mode
 726         then returnRn ()
 727         else checkPrec op p1 False      `thenRn_`
 728              checkPrec op p2 True
 729
 730 checkPrecMatch True op _ = panic "checkPrecMatch"
 731
 732 checkPrec op (ConOpPatIn _ op1 _ _) right
 733   = lookupFixityRn op   `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
 734     lookupFixityRn op1  `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
 735     let
 736         inf_ok = op1_prec > op_prec ||
 737                  (op1_prec == op_prec &&
 738                   (op1_dir == InfixR && op_dir == InfixR && right ||
 739                    op1_dir == InfixL && op_dir == InfixL && not right))
 740
 741         info  = (ppr_op op,  op_fix)
 742         info1 = (ppr_op op1, op1_fix)
 743         (infol, infor) = if right then (info, info1) else (info1, info)
 744     in
 745     checkRn inf_ok (precParseErr infol infor)
 746
 747 checkPrec op pat right
 748   = returnRn ()
 749
 750 -- Check precedence of (arg op) or (op arg) respectively
 751 -- If arg is itself an operator application, its precedence should
 752 -- be higher than that of op
 753 checkSectionPrec left_or_right section op arg
 754   = case arg of
 755         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
 756         NegApp _         -> go_for_it pp_prefix_minus negateFixity
 757         other            -> returnRn ()
 758   where
 759     HsVar op_name = op
 760     go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
 761         = lookupFixityRn op_name        `thenRn` \ op_fix@(Fixity op_prec _) ->
 762           checkRn (op_prec < arg_prec)
 763                   (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
 764 \end{code}
 765
 766 Consider
 767 \begin{verbatim}
 768         a `op1` b `op2` c
 769 \end{verbatim}
 770 @(compareFixity op1 op2)@ tells which way to arrange appication, or
 771 whether there's an error.
 772
 773 \begin{code}
 774 compareFixity :: Fixity -> Fixity
 775               -> (Bool,         -- Error please
 776                   Bool)         -- Associate to the right: a op1 (b op2 c)
 777 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
 778   = case prec1 `compare` prec2 of
 779         GT -> left
 780         LT -> right
 781         EQ -> case (dir1, dir2) of
 782                         (InfixR, InfixR) -> right
 783                         (InfixL, InfixL) -> left
 784                         _                -> error_please
 785   where
 786     right        = (False, True)
 787     left         = (False, False)
 788     error_please = (True,  False)
 789 \end{code}
 790
 791 %************************************************************************
 792 %*                                                                      *
 793 \subsubsection{Literals}
 794 %*                                                                      *
 795 %************************************************************************
 796
 797 When literals occur we have to make sure
 798 that the types and classes they involve
 799 are made available.
 800
 801 \begin{code}
 802 litFVs (HsChar c)
 803    = checkRn (inCharRange c) (bogusCharError c) `thenRn_`
 804      returnRn (unitFV charTyCon_name)
 805
 806 litFVs (HsCharPrim c)         = returnRn (unitFV (getName charPrimTyCon))
 807 litFVs (HsString s)           = returnRn (mkFVs [listTyCon_name, charTyCon_name])
 808 litFVs (HsStringPrim s)       = returnRn (unitFV (getName addrPrimTyCon))
 809 litFVs (HsInt i)              = returnRn (unitFV (getName intTyCon))
 810 litFVs (HsIntPrim i)          = returnRn (unitFV (getName intPrimTyCon))
 811 litFVs (HsFloatPrim f)        = returnRn (unitFV (getName floatPrimTyCon))
 812 litFVs (HsDoublePrim d)       = returnRn (unitFV (getName doublePrimTyCon))
 813 litFVs (HsLitLit l bogus_ty)  = lookupOrigName cCallableClass_RDR       `thenRn` \ cc ->
 814                                 returnRn (unitFV cc)
 815 litFVs lit                    = pprPanic "RnExpr.litFVs" (ppr lit)      -- HsInteger and HsRat only appear
 816                                                                         -- in post-typechecker translations
 817
 818 rnOverLit (HsIntegral i)
 819   | inIntRange i
 820   = returnRn (HsIntegral i, unitFV fromIntegerName)
 821   | otherwise
 822   = lookupOrigNames [fromInteger_RDR, plusInteger_RDR, timesInteger_RDR]        `thenRn` \ ns ->
 823         -- Big integers are built, using + and *, out of small integers
 824         -- [No particular reason why we use fromIntegerName in one case can
 825         --  fromInteger_RDR in the other; but plusInteger_RDR means we
 826         --  can get away without plusIntegerName altogether.]
 827     returnRn (HsIntegral i, ns)
 828
 829 rnOverLit (HsFractional i)
 830   = lookupOrigNames [fromRational_RDR, ratioDataCon_RDR,
 831                      plusInteger_RDR, timesInteger_RDR]  `thenRn` \ ns ->
 832         -- We have to make sure that the Ratio type is imported with
 833         -- its constructor, because literals of type Ratio t are
 834         -- built with that constructor.
 835         -- The Rational type is needed too, but that will come in
 836         -- when fractionalClass does.
 837         -- The plus/times integer operations may be needed to construct the numerator
 838         -- and denominator (see DsUtils.mkIntegerLit)
 839     returnRn (HsFractional i, ns)
 840 \end{code}
 841
 842 %************************************************************************
 843 %*                                                                      *
 844 \subsubsection{Assertion utils}
 845 %*                                                                      *
 846 %************************************************************************
 847
 848 \begin{code}
 849 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
 850 mkAssertExpr =
 851   lookupOrigName assertErr_RDR          `thenRn` \ name ->
 852   getSrcLocRn                           `thenRn` \ sloc ->
 853
 854     -- if we're ignoring asserts, return (\ _ e -> e)
 855     -- if not, return (assertError "src-loc")
 856
 857   if opt_IgnoreAsserts then
 858     getUniqRn                           `thenRn` \ uniq ->
 859     let
 860      vname = mkSysLocalName uniq SLIT("v")
 861      expr  = HsLam ignorePredMatch
 862      loc   = nameSrcLoc vname
 863      ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing
 864                              (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
 865                                     EmptyBinds Nothing)
 866     in
 867     returnRn (expr, unitFV name)
 868   else
 869     let
 870      expr =
 871           HsApp (HsVar name)
 872                 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
 873
 874     in
 875     returnRn (expr, unitFV name)
 876
 877 \end{code}
 878
 879 %************************************************************************
 880 %*                                                                      *
 881 \subsubsection{Errors}
 882 %*                                                                      *
 883 %************************************************************************
 884
 885 \begin{code}
 886 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
 887 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
 888 pp_prefix_minus = ptext SLIT("prefix `-'")
 889
 890 dupFieldErr str (dup:rest)
 891   = hsep [ptext SLIT("duplicate field name"),
 892           quotes (ppr dup),
 893           ptext SLIT("in record"), text str]
 894
 895 precParseErr op1 op2
 896   = hang (ptext SLIT("precedence parsing error"))
 897       4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
 898                ppr_opfix op2,
 899                ptext SLIT("in the same infix expression")])
 900
 901 sectionPrecErr op arg_op section
 902  = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
 903          nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
 904          nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]
 905
 906 nonStdGuardErr guard
 907   = hang (ptext
 908     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
 909     ) 4 (ppr guard)
 910
 911 patSigErr ty
 912   =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
 913         $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
 914
 915 patSynErr e
 916   = sep [ptext SLIT("Pattern syntax in expression context:"),
 917          nest 4 (ppr e)]
 918
 919 doStmtListErr e
 920   = sep [ptext SLIT("`do' statements must end in expression:"),
 921          nest 4 (ppr e)]
 922
 923 bogusCharError c
 924   = ptext SLIT("character literal out of range: '\\") <> int c <> char '\''
 925 \end{code}