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