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