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