ghc/compiler/rename/RnExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnExpr]{Renaming of expressions}
   5
   6 Basically dependency analysis.
   7
   8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
   9 general, all of these functions return a renamed thing, and a set of
  10 free variables.
  11
  12 \begin{code}
  13 module RnExpr (
  14         rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs,
  15         checkPrecMatch
  16    ) where
  17
  18 #include "HsVersions.h"
  19
  20 import {-# SOURCE #-} RnBinds  ( rnBinds )
  21 import {-# SOURCE #-} RnSource ( 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 )
  31 import BasicTypes       ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
  32 import PrelNames        ( hasKey, assertIdKey, minusName, negateName, fromIntName,
  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 rnExpr 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 [GuardStmt _ _, 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 rnExpr stmts                `thenRn` \ ((_, stmts'), fvs) ->
 379         -- check the statement list ends in an expression
 380     case last stmts' of {
 381         ExprStmt _ _ -> returnRn () ;
 382         ReturnStmt _ -> returnRn () ;   -- for list comprehensions
 383         _            -> addErrRn (doStmtListErr e)
 384     }                                   `thenRn_`
 385     returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
 386   where
 387     implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
 388         -- Monad stuff should not be necessary for a list comprehension
 389         -- but the typechecker looks up the bind and return Ids anyway
 390         -- Oh well.
 391
 392
 393 rnExpr (ExplicitList exps)
 394   = rnExprs exps                        `thenRn` \ (exps', fvs) ->
 395     returnRn  (ExplicitList exps', fvs `addOneFV` listTyCon_name)
 396
 397 rnExpr (ExplicitTuple exps boxity)
 398   = rnExprs exps                                `thenRn` \ (exps', fvs) ->
 399     returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
 400   where
 401     tycon_name = tupleTyCon_name boxity (length exps)
 402
 403 rnExpr (RecordCon con_id rbinds)
 404   = lookupOccRn con_id                  `thenRn` \ conname ->
 405     rnRbinds "construction" rbinds      `thenRn` \ (rbinds', fvRbinds) ->
 406     returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
 407
 408 rnExpr (RecordUpd expr rbinds)
 409   = rnExpr expr                 `thenRn` \ (expr', fvExpr) ->
 410     rnRbinds "update" rbinds    `thenRn` \ (rbinds', fvRbinds) ->
 411     returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
 412
 413 rnExpr (ExprWithTySig expr pty)
 414   = rnExpr expr                                            `thenRn` \ (expr', fvExpr) ->
 415     rnHsTypeFVs (text "an expression type signature") pty  `thenRn` \ (pty', fvTy) ->
 416     returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
 417
 418 rnExpr (HsIf p b1 b2 src_loc)
 419   = pushSrcLocRn src_loc $
 420     rnExpr p            `thenRn` \ (p', fvP) ->
 421     rnExpr b1           `thenRn` \ (b1', fvB1) ->
 422     rnExpr b2           `thenRn` \ (b2', fvB2) ->
 423     returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
 424
 425 rnExpr (HsType a)
 426   = rnHsTypeFVs doc a   `thenRn` \ (t, fvT) ->
 427     returnRn (HsType t, fvT)
 428   where
 429     doc = text "renaming a type pattern"
 430
 431 rnExpr (ArithSeqIn seq)
 432   = lookupOrigName enumClass_RDR        `thenRn` \ enum ->
 433     rn_seq seq                          `thenRn` \ (new_seq, fvs) ->
 434     returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
 435   where
 436     rn_seq (From expr)
 437      = rnExpr expr      `thenRn` \ (expr', fvExpr) ->
 438        returnRn (From expr', fvExpr)
 439
 440     rn_seq (FromThen expr1 expr2)
 441      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 442        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 443        returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 444
 445     rn_seq (FromTo expr1 expr2)
 446      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 447        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 448        returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 449
 450     rn_seq (FromThenTo expr1 expr2 expr3)
 451      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 452        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 453        rnExpr expr3     `thenRn` \ (expr3', fvExpr3) ->
 454        returnRn (FromThenTo expr1' expr2' expr3',
 455                   plusFVs [fvExpr1, fvExpr2, fvExpr3])
 456 \end{code}
 457
 458 These three are pattern syntax appearing in expressions.
 459 Since all the symbols are reservedops we can simply reject them.
 460 We return a (bogus) EWildPat in each case.
 461
 462 \begin{code}
 463 rnExpr e@EWildPat = addErrRn (patSynErr e)      `thenRn_`
 464                     returnRn (EWildPat, emptyFVs)
 465
 466 rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e)  `thenRn_`
 467                         returnRn (EWildPat, emptyFVs)
 468
 469 rnExpr e@(ELazyPat _) = addErrRn (patSynErr e)  `thenRn_`
 470                         returnRn (EWildPat, emptyFVs)
 471 \end{code}
 472
 473
 474
 475 %************************************************************************
 476 %*                                                                      *
 477 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 478 %*                                                                      *
 479 %************************************************************************
 480
 481 \begin{code}
 482 rnRbinds str rbinds
 483   = mapRn_ field_dup_err dup_fields     `thenRn_`
 484     mapFvRn rn_rbind rbinds             `thenRn` \ (rbinds', fvRbind) ->
 485     returnRn (rbinds', fvRbind)
 486   where
 487     (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
 488
 489     field_dup_err dups = addErrRn (dupFieldErr str dups)
 490
 491     rn_rbind (field, expr, pun)
 492       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 493         rnExpr expr             `thenRn` \ (expr', fvExpr) ->
 494         returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
 495
 496 rnRpats rpats
 497   = mapRn_ field_dup_err dup_fields     `thenRn_`
 498     mapFvRn rn_rpat rpats               `thenRn` \ (rpats', fvs) ->
 499     returnRn (rpats', fvs)
 500   where
 501     (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
 502
 503     field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
 504
 505     rn_rpat (field, pat, pun)
 506       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 507         rnPat pat               `thenRn` \ (pat', fvs) ->
 508         returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
 509 \end{code}
 510
 511 %************************************************************************
 512 %*                                                                      *
 513 \subsubsection{@rnIPBinds@s: in implicit parameter bindings}            *
 514 %*                                                                      *
 515 %************************************************************************
 516
 517 \begin{code}
 518 rnIPBinds [] = returnRn ([], emptyFVs)
 519 rnIPBinds ((n, expr) : binds)
 520   = newIPName n                 `thenRn` \ name ->
 521     rnExpr expr                 `thenRn` \ (expr',fvExpr) ->
 522     rnIPBinds binds             `thenRn` \ (binds',fvBinds) ->
 523     returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
 524
 525 \end{code}
 526
 527 %************************************************************************
 528 %*                                                                      *
 529 \subsubsection{@Stmt@s: in @do@ expressions}
 530 %*                                                                      *
 531 %************************************************************************
 532
 533 Note that although some bound vars may appear in the free var set for
 534 the first qual, these will eventually be removed by the caller. For
 535 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
 536 @[q <- r, p <- q]@, the free var set for @q <- r@ will
 537 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 538 @r@ will be removed only when we finally return from examining all the
 539 Quals.
 540
 541 \begin{code}
 542 type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
 543
 544 rnStmts :: RnExprTy
 545         -> [RdrNameStmt]
 546         -> RnMS (([Name], [RenamedStmt]), FreeVars)
 547
 548 rnStmts rn_expr []
 549   = returnRn (([], []), emptyFVs)
 550
 551 rnStmts rn_expr (stmt:stmts)
 552   = getLocalNameEnv             `thenRn` \ name_env ->
 553     rnStmt rn_expr stmt                         $ \ stmt' ->
 554     rnStmts rn_expr stmts                       `thenRn` \ ((binders, stmts'), fvs) ->
 555     returnRn ((binders, stmt' : stmts'), fvs)
 556
 557 rnStmt :: RnExprTy -> RdrNameStmt
 558        -> (RenamedStmt -> RnMS (([Name], a), FreeVars))
 559        -> RnMS (([Name], a), FreeVars)
 560 -- Because of mutual recursion we have to pass in rnExpr.
 561
 562 rnStmt rn_expr (ParStmt stmtss) thing_inside
 563   = mapFvRn (rnStmts rn_expr) stmtss    `thenRn` \ (bndrstmtss, fv_stmtss) ->
 564     let binderss = map fst bndrstmtss
 565         checkBndrs all_bndrs bndrs
 566           = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_`
 567             returnRn (bndrs ++ all_bndrs)
 568         eqOcc n1 n2 = nameOccName n1 == nameOccName n2
 569         err = text "duplicate binding in parallel list comprehension"
 570     in
 571     foldlRn checkBndrs [] binderss      `thenRn` \ binders ->
 572     bindLocalNamesFV binders            $
 573     thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) ->
 574     returnRn ((rest_bndrs ++ binders, result), fv_stmtss `plusFV` fv_rest)
 575
 576 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
 577   = pushSrcLocRn src_loc $
 578     rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 579     bindLocalsFVRn doc binders                  $ \ new_binders ->
 580     rnPat pat                                   `thenRn` \ (pat', fv_pat) ->
 581     thing_inside (BindStmt pat' expr' src_loc)  `thenRn` \ ((rest_binders, result), fvs) ->
 582     -- ZZ is shadowing handled correctly?
 583     returnRn ((rest_binders ++ new_binders, result),
 584               fv_expr `plusFV` fvs `plusFV` fv_pat)
 585   where
 586     binders = collectPatBinders pat
 587     doc = text "a pattern in do binding"
 588
 589 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
 590   = pushSrcLocRn src_loc $
 591     rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 592     thing_inside (ExprStmt expr' src_loc)       `thenRn` \ (result, fvs) ->
 593     returnRn (result, fv_expr `plusFV` fvs)
 594
 595 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
 596   = pushSrcLocRn src_loc $
 597     rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 598     thing_inside (GuardStmt expr' src_loc)      `thenRn` \ (result, fvs) ->
 599     returnRn (result, fv_expr `plusFV` fvs)
 600
 601 rnStmt rn_expr (ReturnStmt expr) thing_inside
 602   = rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 603     thing_inside (ReturnStmt expr')             `thenRn` \ (result, fvs) ->
 604     returnRn (result, fv_expr `plusFV` fvs)
 605
 606 rnStmt rn_expr (LetStmt binds) thing_inside
 607   = rnBinds binds                               $ \ binds' ->
 608     thing_inside (LetStmt binds')
 609
 610 \end{code}
 611
 612 %************************************************************************
 613 %*                                                                      *
 614 \subsubsection{Precedence Parsing}
 615 %*                                                                      *
 616 %************************************************************************
 617
 618 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 619 are assumed to be already correctly arranged.  It needs the fixities
 620 recorded in the OpApp nodes, because fixity info applies to the things
 621 the programmer actually wrote, so you can't find it out from the Name.
 622
 623 Furthermore, the second argument is guaranteed not to be another
 624 operator application.  Why? Because the parser parses all
 625 operator appications left-associatively, EXCEPT negation, which
 626 we need to handle specially.
 627
 628 \begin{code}
 629 mkOpAppRn :: RenamedHsExpr                      -- Left operand; already rearranged
 630           -> RenamedHsExpr -> Fixity            -- Operator and fixity
 631           -> RenamedHsExpr                      -- Right operand (not an OpApp, but might
 632                                                 -- be a NegApp)
 633           -> RnMS RenamedHsExpr
 634
 635 ---------------------------
 636 -- (e11 `op1` e12) `op2` e2
 637 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
 638   | nofix_error
 639   = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
 640     returnRn (OpApp e1 op2 fix2 e2)
 641
 642   | associate_right
 643   = mkOpAppRn e12 op2 fix2 e2           `thenRn` \ new_e ->
 644     returnRn (OpApp e11 op1 fix1 new_e)
 645   where
 646     (nofix_error, associate_right) = compareFixity fix1 fix2
 647
 648 ---------------------------
 649 --      (- neg_arg) `op` e2
 650 mkOpAppRn e1@(NegApp neg_arg) op2 fix2 e2
 651   | nofix_error
 652   = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))    `thenRn_`
 653     returnRn (OpApp e1 op2 fix2 e2)
 654
 655   | associate_right
 656   = mkOpAppRn neg_arg op2 fix2 e2       `thenRn` \ new_e ->
 657     returnRn (NegApp new_e)
 658   where
 659     (nofix_error, associate_right) = compareFixity negateFixity fix2
 660
 661 ---------------------------
 662 --      e1 `op` - neg_arg
 663 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg)       -- NegApp can occur on the right
 664   | not associate_right                                 -- We *want* right association
 665   = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))  `thenRn_`
 666     returnRn (OpApp e1 op1 fix1 e2)
 667   where
 668     (_, associate_right) = compareFixity fix1 negateFixity
 669
 670 ---------------------------
 671 --      Default case
 672 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 673   = ASSERT2( right_op_ok fix e2,
 674              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
 675     )
 676     returnRn (OpApp e1 op fix e2)
 677
 678 -- Parser left-associates everything, but
 679 -- derived instances may have correctly-associated things to
 680 -- in the right operarand.  So we just check that the right operand is OK
 681 right_op_ok fix1 (OpApp _ _ fix2 _)
 682   = not error_please && associate_right
 683   where
 684     (error_please, associate_right) = compareFixity fix1 fix2
 685 right_op_ok fix1 other
 686   = True
 687
 688 -- Parser initially makes negation bind more tightly than any other operator
 689 mkNegAppRn neg_arg
 690   =
 691 #ifdef DEBUG
 692     getModeRn                   `thenRn` \ mode ->
 693     ASSERT( not_op_app mode neg_arg )
 694 #endif
 695     returnRn (NegApp neg_arg)
 696
 697 not_op_app SourceMode (OpApp _ _ _ _) = False
 698 not_op_app mode other                 = True
 699 \end{code}
 700
 701 \begin{code}
 702 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
 703              -> RnMS RenamedPat
 704
 705 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
 706              op2 fix2 p2
 707   | nofix_error
 708   = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
 709     returnRn (ConOpPatIn p1 op2 fix2 p2)
 710
 711   | associate_right
 712   = mkConOpPatRn p12 op2 fix2 p2                `thenRn` \ new_p ->
 713     returnRn (ConOpPatIn p11 op1 fix1 new_p)
 714
 715   where
 716     (nofix_error, associate_right) = compareFixity fix1 fix2
 717
 718 mkConOpPatRn p1 op fix p2                       -- Default case, no rearrangment
 719   = ASSERT( not_op_pat p2 )
 720     returnRn (ConOpPatIn p1 op fix p2)
 721
 722 not_op_pat (ConOpPatIn _ _ _ _) = False
 723 not_op_pat other                = True
 724 \end{code}
 725
 726 \begin{code}
 727 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
 728
 729 checkPrecMatch False fn match
 730   = returnRn ()
 731
 732 checkPrecMatch True op (Match _ (p1:p2:_) _ _)
 733         -- True indicates an infix lhs
 734   = getModeRn           `thenRn` \ mode ->
 735         -- See comments with rnExpr (OpApp ...)
 736     if isInterfaceMode mode
 737         then returnRn ()
 738         else checkPrec op p1 False      `thenRn_`
 739              checkPrec op p2 True
 740
 741 checkPrecMatch True op _ = panic "checkPrecMatch"
 742
 743 checkPrec op (ConOpPatIn _ op1 _ _) right
 744   = lookupFixityRn op   `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
 745     lookupFixityRn op1  `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
 746     let
 747         inf_ok = op1_prec > op_prec ||
 748                  (op1_prec == op_prec &&
 749                   (op1_dir == InfixR && op_dir == InfixR && right ||
 750                    op1_dir == InfixL && op_dir == InfixL && not right))
 751
 752         info  = (ppr_op op,  op_fix)
 753         info1 = (ppr_op op1, op1_fix)
 754         (infol, infor) = if right then (info, info1) else (info1, info)
 755     in
 756     checkRn inf_ok (precParseErr infol infor)
 757
 758 checkPrec op pat right
 759   = returnRn ()
 760
 761 -- Check precedence of (arg op) or (op arg) respectively
 762 -- If arg is itself an operator application, its precedence should
 763 -- be higher than that of op
 764 checkSectionPrec left_or_right section op arg
 765   = case arg of
 766         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
 767         NegApp _         -> go_for_it pp_prefix_minus negateFixity
 768         other            -> returnRn ()
 769   where
 770     HsVar op_name = op
 771     go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
 772         = lookupFixityRn op_name        `thenRn` \ op_fix@(Fixity op_prec _) ->
 773           checkRn (op_prec < arg_prec)
 774                   (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
 775 \end{code}
 776
 777 Consider
 778 \begin{verbatim}
 779         a `op1` b `op2` c
 780 \end{verbatim}
 781 @(compareFixity op1 op2)@ tells which way to arrange appication, or
 782 whether there's an error.
 783
 784 \begin{code}
 785 compareFixity :: Fixity -> Fixity
 786               -> (Bool,         -- Error please
 787                   Bool)         -- Associate to the right: a op1 (b op2 c)
 788 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
 789   = case prec1 `compare` prec2 of
 790         GT -> left
 791         LT -> right
 792         EQ -> case (dir1, dir2) of
 793                         (InfixR, InfixR) -> right
 794                         (InfixL, InfixL) -> left
 795                         _                -> error_please
 796   where
 797     right        = (False, True)
 798     left         = (False, False)
 799     error_please = (True,  False)
 800 \end{code}
 801
 802 %************************************************************************
 803 %*                                                                      *
 804 \subsubsection{Literals}
 805 %*                                                                      *
 806 %************************************************************************
 807
 808 When literals occur we have to make sure
 809 that the types and classes they involve
 810 are made available.
 811
 812 \begin{code}
 813 litFVs (HsChar c)             = returnRn (unitFV charTyCon_name)
 814 litFVs (HsCharPrim c)         = returnRn (unitFV (getName charPrimTyCon))
 815 litFVs (HsString s)           = returnRn (mkFVs [listTyCon_name, charTyCon_name])
 816 litFVs (HsStringPrim s)       = returnRn (unitFV (getName addrPrimTyCon))
 817 litFVs (HsInt i)              = returnRn (unitFV (getName intTyCon))
 818 litFVs (HsIntPrim i)          = returnRn (unitFV (getName intPrimTyCon))
 819 litFVs (HsFloatPrim f)        = returnRn (unitFV (getName floatPrimTyCon))
 820 litFVs (HsDoublePrim d)       = returnRn (unitFV (getName doublePrimTyCon))
 821 litFVs (HsLitLit l bogus_ty)  = lookupOrigName cCallableClass_RDR       `thenRn` \ cc ->
 822                                 returnRn (unitFV cc)
 823 litFVs lit                    = pprPanic "RnExpr.litFVs" (ppr lit)      -- HsInteger and HsRat only appear
 824                                                                         -- in post-typechecker translations
 825
 826 rnOverLit (HsIntegral i)
 827   | inIntRange i
 828   = returnRn (HsIntegral i, unitFV fromIntName)
 829   | otherwise
 830   = lookupOrigNames [fromInteger_RDR, plusInteger_RDR, timesInteger_RDR]        `thenRn` \ ns ->
 831         -- Big integers are built, using + and *, out of small integers
 832     returnRn (HsIntegral i, ns)
 833
 834 rnOverLit (HsFractional i)
 835   = lookupOrigNames [fromRational_RDR, ratioDataCon_RDR,
 836                      plusInteger_RDR, timesInteger_RDR]  `thenRn` \ ns ->
 837         -- We have to make sure that the Ratio type is imported with
 838         -- its constructor, because literals of type Ratio t are
 839         -- built with that constructor.
 840         -- The Rational type is needed too, but that will come in
 841         -- when fractionalClass does.
 842         -- The plus/times integer operations may be needed to construct the numerator
 843         -- and denominator (see DsUtils.mkIntegerLit)
 844     returnRn (HsFractional i, ns)
 845 \end{code}
 846
 847 %************************************************************************
 848 %*                                                                      *
 849 \subsubsection{Assertion utils}
 850 %*                                                                      *
 851 %************************************************************************
 852
 853 \begin{code}
 854 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
 855 mkAssertExpr =
 856   lookupOrigName assertErr_RDR          `thenRn` \ name ->
 857   getSrcLocRn                           `thenRn` \ sloc ->
 858
 859     -- if we're ignoring asserts, return (\ _ e -> e)
 860     -- if not, return (assertError "src-loc")
 861
 862   if opt_IgnoreAsserts then
 863     getUniqRn                           `thenRn` \ uniq ->
 864     let
 865      vname = mkSysLocalName uniq SLIT("v")
 866      expr  = HsLam ignorePredMatch
 867      loc   = nameSrcLoc vname
 868      ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing
 869                              (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
 870                                     EmptyBinds Nothing)
 871     in
 872     returnRn (expr, unitFV name)
 873   else
 874     let
 875      expr =
 876           HsApp (HsVar name)
 877                 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
 878
 879     in
 880     returnRn (expr, unitFV name)
 881
 882 \end{code}
 883
 884 %************************************************************************
 885 %*                                                                      *
 886 \subsubsection{Errors}
 887 %*                                                                      *
 888 %************************************************************************
 889
 890 \begin{code}
 891 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
 892 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
 893 pp_prefix_minus = ptext SLIT("prefix `-'")
 894
 895 dupFieldErr str (dup:rest)
 896   = hsep [ptext SLIT("duplicate field name"),
 897           quotes (ppr dup),
 898           ptext SLIT("in record"), text str]
 899
 900 precParseErr op1 op2
 901   = hang (ptext SLIT("precedence parsing error"))
 902       4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
 903                ppr_opfix op2,
 904                ptext SLIT("in the same infix expression")])
 905
 906 sectionPrecErr op arg_op section
 907  = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
 908          nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
 909          nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]
 910
 911 nonStdGuardErr guard
 912   = hang (ptext
 913     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
 914     ) 4 (ppr guard)
 915
 916 patSigErr ty
 917   =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
 918         $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
 919
 920 patSynErr e
 921   = sep [ptext SLIT("Pattern syntax in expression context:"),
 922          nest 4 (ppr e)]
 923
 924 doStmtListErr e
 925   = sep [ptext SLIT("`do' statements must end in expression:"),
 926          nest 4 (ppr e)]
 927 \end{code}