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