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