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