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, assertName,
  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 then
 296         -- We expand it to (GHCerr.assert__ location)
 297         mkAssertExpr
 298     else
 299         -- The normal case
 300        returnM (HsVar name, unitFV name)
 301
 302 rnExpr (HsIPVar v)
 303   = newIPName v                 `thenM` \ name ->
 304     let
 305         fvs = case name of
 306                 Linear _  -> mkFVs [splitName, fstName, sndName]
 307                 Dupable _ -> emptyFVs
 308     in
 309     returnM (HsIPVar name, fvs)
 310
 311 rnExpr (HsLit lit)
 312   = litFVs lit          `thenM` \ fvs ->
 313     returnM (HsLit lit, fvs)
 314
 315 rnExpr (HsOverLit lit)
 316   = rnOverLit lit               `thenM` \ (lit', fvs) ->
 317     returnM (HsOverLit lit', fvs)
 318
 319 rnExpr (HsLam match)
 320   = rnMatch LambdaExpr match    `thenM` \ (match', fvMatch) ->
 321     returnM (HsLam match', fvMatch)
 322
 323 rnExpr (HsApp fun arg)
 324   = rnExpr fun          `thenM` \ (fun',fvFun) ->
 325     rnExpr arg          `thenM` \ (arg',fvArg) ->
 326     returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
 327
 328 rnExpr (OpApp e1 op _ e2)
 329   = rnExpr e1                           `thenM` \ (e1', fv_e1) ->
 330     rnExpr e2                           `thenM` \ (e2', fv_e2) ->
 331     rnExpr op                           `thenM` \ (op'@(HsVar op_name), fv_op) ->
 332
 333         -- Deal with fixity
 334         -- When renaming code synthesised from "deriving" declarations
 335         -- we're in Interface mode, and we should ignore fixity; assume
 336         -- that the deriving code generator got the association correct
 337         -- Don't even look up the fixity when in interface mode
 338     getModeRn                           `thenM` \ mode ->
 339     (if isInterfaceMode mode
 340         then returnM (OpApp e1' op' defaultFixity e2')
 341         else lookupFixityRn op_name             `thenM` \ fixity ->
 342              mkOpAppRn e1' op' fixity e2'
 343     )                                   `thenM` \ final_e ->
 344
 345     returnM (final_e,
 346               fv_e1 `plusFV` fv_op `plusFV` fv_e2)
 347
 348 rnExpr (NegApp e _)
 349   = rnExpr e                    `thenM` \ (e', fv_e) ->
 350     lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
 351     mkNegAppRn e' neg_name      `thenM` \ final_e ->
 352     returnM (final_e, fv_e `plusFV` fv_neg)
 353
 354 rnExpr (HsPar e)
 355   = rnExpr e            `thenM` \ (e', fvs_e) ->
 356     returnM (HsPar e', fvs_e)
 357
 358 -- Template Haskell extensions
 359 rnExpr (HsBracket br_body)
 360   = checkGHCI (thErr "bracket")         `thenM_`
 361     rnBracket br_body                   `thenM` \ (body', fvs_e) ->
 362     returnM (HsBracket body', fvs_e `addOneFV` qTyConName)
 363         -- We use the Q tycon as a proxy to haul in all the smart
 364         -- constructors; see the hack in RnIfaces
 365
 366 rnExpr (HsSplice n e)
 367   = checkGHCI (thErr "splice")          `thenM_`
 368     getSrcLocM                          `thenM` \ loc ->
 369     newLocalsRn [(n,loc)]               `thenM` \ [n'] ->
 370     rnExpr e                            `thenM` \ (e', fvs_e) ->
 371     returnM (HsSplice n' e', fvs_e)
 372
 373 rnExpr section@(SectionL expr op)
 374   = rnExpr expr                                 `thenM` \ (expr', fvs_expr) ->
 375     rnExpr op                                   `thenM` \ (op', fvs_op) ->
 376     checkSectionPrec InfixL section op' expr' `thenM_`
 377     returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
 378
 379 rnExpr section@(SectionR op expr)
 380   = rnExpr op                                   `thenM` \ (op',   fvs_op) ->
 381     rnExpr expr                                 `thenM` \ (expr', fvs_expr) ->
 382     checkSectionPrec InfixR section op' expr'   `thenM_`
 383     returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
 384
 385 rnExpr (HsCCall fun args may_gc is_casm _)
 386         -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
 387   = rnExprs args                                `thenM` \ (args', fvs_args) ->
 388     returnM (HsCCall fun args' may_gc is_casm placeHolderType,
 389               fvs_args `plusFV` mkFVs [cCallableClassName,
 390                                        cReturnableClassName,
 391                                        ioDataConName])
 392
 393 rnExpr (HsSCC lbl expr)
 394   = rnExpr expr         `thenM` \ (expr', fvs_expr) ->
 395     returnM (HsSCC lbl expr', fvs_expr)
 396
 397 rnExpr (HsCase expr ms src_loc)
 398   = addSrcLoc src_loc $
 399     rnExpr expr                         `thenM` \ (new_expr, e_fvs) ->
 400     mapFvRn (rnMatch CaseAlt) ms        `thenM` \ (new_ms, ms_fvs) ->
 401     returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
 402
 403 rnExpr (HsLet binds expr)
 404   = rnBinds binds               $ \ binds' ->
 405     rnExpr expr                  `thenM` \ (expr',fvExpr) ->
 406     returnM (HsLet binds' expr', fvExpr)
 407
 408 rnExpr (HsWith expr binds is_with)
 409   = warnIf is_with withWarning `thenM_`
 410     rnExpr expr                 `thenM` \ (expr',fvExpr) ->
 411     rnIPBinds binds             `thenM` \ (binds',fvBinds) ->
 412     returnM (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds)
 413
 414 rnExpr e@(HsDo do_or_lc stmts _ ty src_loc)
 415   = addSrcLoc src_loc $
 416     rnStmts stmts                       `thenM` \ ((_, stmts'), fvs) ->
 417
 418         -- Check the statement list ends in an expression
 419     case last stmts' of {
 420         ResultStmt _ _ -> returnM () ;
 421         _              -> addErr (doStmtListErr e)
 422     }                                   `thenM_`
 423
 424         -- Generate the rebindable syntax for the monad
 425     (case do_or_lc of
 426         DoExpr -> mapAndUnzipM lookupSyntaxName monadNames
 427         other  -> returnM ([], [])
 428     )                                   `thenM` \ (monad_names', monad_fvs) ->
 429
 430     returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
 431               fvs `plusFV` implicit_fvs `plusFV` plusFVs monad_fvs)
 432   where
 433     implicit_fvs = case do_or_lc of
 434       PArrComp -> mkFVs [replicatePName, mapPName, filterPName,
 435                          crossPName, zipPName]
 436       ListComp -> mkFVs [foldrName, buildName]
 437       DoExpr   -> emptyFVs
 438
 439 rnExpr (ExplicitList _ exps)
 440   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 441     returnM  (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
 442
 443 rnExpr (ExplicitPArr _ exps)
 444   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 445     returnM  (ExplicitPArr placeHolderType exps',
 446                fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
 447
 448 rnExpr (ExplicitTuple exps boxity)
 449   = rnExprs exps                                `thenM` \ (exps', fvs) ->
 450     returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
 451   where
 452     tycon_name = tupleTyCon_name boxity (length exps)
 453
 454 rnExpr (RecordCon con_id rbinds)
 455   = lookupOccRn con_id                  `thenM` \ conname ->
 456     rnRbinds "construction" rbinds      `thenM` \ (rbinds', fvRbinds) ->
 457     returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
 458
 459 rnExpr (RecordUpd expr rbinds)
 460   = rnExpr expr                 `thenM` \ (expr', fvExpr) ->
 461     rnRbinds "update" rbinds    `thenM` \ (rbinds', fvRbinds) ->
 462     returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
 463
 464 rnExpr (ExprWithTySig expr pty)
 465   = rnExpr expr                 `thenM` \ (expr', fvExpr) ->
 466     rnHsTypeFVs doc pty         `thenM` \ (pty', fvTy) ->
 467     returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
 468   where
 469     doc = text "In an expression type signature"
 470
 471 rnExpr (HsIf p b1 b2 src_loc)
 472   = addSrcLoc src_loc $
 473     rnExpr p            `thenM` \ (p', fvP) ->
 474     rnExpr b1           `thenM` \ (b1', fvB1) ->
 475     rnExpr b2           `thenM` \ (b2', fvB2) ->
 476     returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
 477
 478 rnExpr (HsType a)
 479   = rnHsTypeFVs doc a   `thenM` \ (t, fvT) ->
 480     returnM (HsType t, fvT)
 481   where
 482     doc = text "In a type argument"
 483
 484 rnExpr (ArithSeqIn seq)
 485   = rn_seq seq                          `thenM` \ (new_seq, fvs) ->
 486     returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
 487   where
 488     rn_seq (From expr)
 489      = rnExpr expr      `thenM` \ (expr', fvExpr) ->
 490        returnM (From expr', fvExpr)
 491
 492     rn_seq (FromThen expr1 expr2)
 493      = rnExpr expr1     `thenM` \ (expr1', fvExpr1) ->
 494        rnExpr expr2     `thenM` \ (expr2', fvExpr2) ->
 495        returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 496
 497     rn_seq (FromTo expr1 expr2)
 498      = rnExpr expr1     `thenM` \ (expr1', fvExpr1) ->
 499        rnExpr expr2     `thenM` \ (expr2', fvExpr2) ->
 500        returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 501
 502     rn_seq (FromThenTo expr1 expr2 expr3)
 503      = rnExpr expr1     `thenM` \ (expr1', fvExpr1) ->
 504        rnExpr expr2     `thenM` \ (expr2', fvExpr2) ->
 505        rnExpr expr3     `thenM` \ (expr3', fvExpr3) ->
 506        returnM (FromThenTo expr1' expr2' expr3',
 507                   plusFVs [fvExpr1, fvExpr2, fvExpr3])
 508
 509 rnExpr (PArrSeqIn seq)
 510   = rn_seq seq                         `thenM` \ (new_seq, fvs) ->
 511     returnM (PArrSeqIn new_seq,
 512               fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
 513   where
 514
 515     -- the parser shouldn't generate these two
 516     --
 517     rn_seq (From     _  ) = panic "RnExpr.rnExpr: Infinite parallel array!"
 518     rn_seq (FromThen _ _) = panic "RnExpr.rnExpr: Infinite parallel array!"
 519
 520     rn_seq (FromTo expr1 expr2)
 521      = rnExpr expr1     `thenM` \ (expr1', fvExpr1) ->
 522        rnExpr expr2     `thenM` \ (expr2', fvExpr2) ->
 523        returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 524     rn_seq (FromThenTo expr1 expr2 expr3)
 525      = rnExpr expr1     `thenM` \ (expr1', fvExpr1) ->
 526        rnExpr expr2     `thenM` \ (expr2', fvExpr2) ->
 527        rnExpr expr3     `thenM` \ (expr3', fvExpr3) ->
 528        returnM (FromThenTo expr1' expr2' expr3',
 529                   plusFVs [fvExpr1, fvExpr2, fvExpr3])
 530 \end{code}
 531
 532 These three are pattern syntax appearing in expressions.
 533 Since all the symbols are reservedops we can simply reject them.
 534 We return a (bogus) EWildPat in each case.
 535
 536 \begin{code}
 537 rnExpr e@EWildPat = addErr (patSynErr e)        `thenM_`
 538                     returnM (EWildPat, emptyFVs)
 539
 540 rnExpr e@(EAsPat _ _) = addErr (patSynErr e)    `thenM_`
 541                         returnM (EWildPat, emptyFVs)
 542
 543 rnExpr e@(ELazyPat _) = addErr (patSynErr e)    `thenM_`
 544                         returnM (EWildPat, emptyFVs)
 545 \end{code}
 546
 547
 548
 549 %************************************************************************
 550 %*                                                                      *
 551 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 552 %*                                                                      *
 553 %************************************************************************
 554
 555 \begin{code}
 556 rnRbinds str rbinds
 557   = mappM_ field_dup_err dup_fields     `thenM_`
 558     mapFvRn rn_rbind rbinds             `thenM` \ (rbinds', fvRbind) ->
 559     returnM (rbinds', fvRbind)
 560   where
 561     (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
 562
 563     field_dup_err dups = addErr (dupFieldErr str dups)
 564
 565     rn_rbind (field, expr)
 566       = lookupGlobalOccRn field `thenM` \ fieldname ->
 567         rnExpr expr             `thenM` \ (expr', fvExpr) ->
 568         returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
 569
 570 rnRpats rpats
 571   = mappM_ field_dup_err dup_fields     `thenM_`
 572     mapFvRn rn_rpat rpats               `thenM` \ (rpats', fvs) ->
 573     returnM (rpats', fvs)
 574   where
 575     (_, dup_fields) = removeDups compare [ f | (f,_) <- rpats ]
 576
 577     field_dup_err dups = addErr (dupFieldErr "pattern" dups)
 578
 579     rn_rpat (field, pat)
 580       = lookupGlobalOccRn field `thenM` \ fieldname ->
 581         rnPat pat               `thenM` \ (pat', fvs) ->
 582         returnM ((fieldname, pat'), fvs `addOneFV` fieldname)
 583 \end{code}
 584
 585 %************************************************************************
 586 %*                                                                      *
 587 \subsubsection{@rnIPBinds@s: in implicit parameter bindings}            *
 588 %*                                                                      *
 589 %************************************************************************
 590
 591 \begin{code}
 592 rnIPBinds [] = returnM ([], emptyFVs)
 593 rnIPBinds ((n, expr) : binds)
 594   = newIPName n                 `thenM` \ name ->
 595     rnExpr expr                 `thenM` \ (expr',fvExpr) ->
 596     rnIPBinds binds             `thenM` \ (binds',fvBinds) ->
 597     returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)
 598
 599 \end{code}
 600
 601 %************************************************************************
 602 %*                                                                      *
 603         Template Haskell brackets
 604 %*                                                                      *
 605 %************************************************************************
 606
 607 \begin{code}
 608 rnBracket (ExpBr e) = rnExpr e          `thenM` \ (e', fvs) ->
 609                       returnM (ExpBr e', fvs)
 610 rnBracket (PatBr p) = rnPat p           `thenM` \ (p', fvs) ->
 611                       returnM (PatBr p', fvs)
 612 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
 613                       returnM (TypBr t', fvs)
 614                     where
 615                       doc = ptext SLIT("In a Template-Haskell quoted type")
 616 rnBracket (DecBr ds) = rnSrcDecls ds    `thenM` \ (tcg_env, ds', fvs) ->
 617                         -- Discard the tcg_env; it contains the extended global RdrEnv
 618                         -- because there is no scope that these decls cover (yet!)
 619                        returnM (DecBr ds', fvs)
 620 \end{code}
 621
 622 %************************************************************************
 623 %*                                                                      *
 624 \subsubsection{@Stmt@s: in @do@ expressions}
 625 %*                                                                      *
 626 %************************************************************************
 627
 628 Note that although some bound vars may appear in the free var set for
 629 the first qual, these will eventually be removed by the caller. For
 630 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
 631 @[q <- r, p <- q]@, the free var set for @q <- r@ will
 632 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 633 @r@ will be removed only when we finally return from examining all the
 634 Quals.
 635
 636 \begin{code}
 637 rnStmts :: [RdrNameStmt]
 638         -> RnM (([Name], [RenamedStmt]), FreeVars)
 639
 640 rnStmts []
 641   = returnM (([], []), emptyFVs)
 642
 643 rnStmts (stmt:stmts)
 644   = getLocalRdrEnv              `thenM` \ name_env ->
 645     rnStmt stmt                         $ \ stmt' ->
 646     rnStmts stmts                       `thenM` \ ((binders, stmts'), fvs) ->
 647     returnM ((binders, stmt' : stmts'), fvs)
 648
 649 rnStmt :: RdrNameStmt
 650        -> (RenamedStmt -> RnM (([Name], a), FreeVars))
 651        -> RnM (([Name], a), FreeVars)
 652 -- The thing list of names returned is the list returned by the
 653 -- thing_inside, plus the binders of the arguments stmt
 654
 655 rnStmt (ParStmt stmtss) thing_inside
 656   = mapFvRn rnStmts stmtss              `thenM` \ (bndrstmtss, fv_stmtss) ->
 657     let binderss = map fst bndrstmtss
 658         checkBndrs all_bndrs bndrs
 659           = checkErr (null (intersectBy eqOcc all_bndrs bndrs)) err `thenM_`
 660             returnM (bndrs ++ all_bndrs)
 661         eqOcc n1 n2 = nameOccName n1 == nameOccName n2
 662         err = text "duplicate binding in parallel list comprehension"
 663     in
 664     foldlM checkBndrs [] binderss       `thenM` \ new_binders ->
 665     bindLocalNamesFV new_binders        $
 666     thing_inside (ParStmtOut bndrstmtss)`thenM` \ ((rest_bndrs, result), fv_rest) ->
 667     returnM ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest)
 668
 669 rnStmt (BindStmt pat expr src_loc) thing_inside
 670   = addSrcLoc src_loc $
 671     rnExpr expr                                 `thenM` \ (expr', fv_expr) ->
 672     bindPatSigTyVars (collectSigTysFromPat pat) $
 673     bindLocalsFVRn doc (collectPatBinders pat)  $ \ new_binders ->
 674     rnPat pat                                   `thenM` \ (pat', fv_pat) ->
 675     thing_inside (BindStmt pat' expr' src_loc)  `thenM` \ ((rest_binders, result), fvs) ->
 676     returnM ((new_binders ++ rest_binders, result),
 677               fv_expr `plusFV` fvs `plusFV` fv_pat)
 678   where
 679     doc = text "In a pattern in 'do' binding"
 680
 681 rnStmt (ExprStmt expr _ src_loc) thing_inside
 682   = addSrcLoc src_loc $
 683     rnExpr expr                                                 `thenM` \ (expr', fv_expr) ->
 684     thing_inside (ExprStmt expr' placeHolderType src_loc)       `thenM` \ (result, fvs) ->
 685     returnM (result, fv_expr `plusFV` fvs)
 686
 687 rnStmt (ResultStmt expr src_loc) thing_inside
 688   = addSrcLoc src_loc $
 689     rnExpr expr                                 `thenM` \ (expr', fv_expr) ->
 690     thing_inside (ResultStmt expr' src_loc)     `thenM` \ (result, fvs) ->
 691     returnM (result, fv_expr `plusFV` fvs)
 692
 693 rnStmt (LetStmt binds) thing_inside
 694   = rnBinds binds                               $ \ binds' ->
 695     let new_binders = collectHsBinders binds' in
 696     thing_inside (LetStmt binds')    `thenM` \ ((rest_binders, result), fvs) ->
 697     returnM ((new_binders ++ rest_binders, result), fvs )
 698 \end{code}
 699
 700 %************************************************************************
 701 %*                                                                      *
 702 \subsubsection{Precedence Parsing}
 703 %*                                                                      *
 704 %************************************************************************
 705
 706 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 707 are assumed to be already correctly arranged.  It needs the fixities
 708 recorded in the OpApp nodes, because fixity info applies to the things
 709 the programmer actually wrote, so you can't find it out from the Name.
 710
 711 Furthermore, the second argument is guaranteed not to be another
 712 operator application.  Why? Because the parser parses all
 713 operator appications left-associatively, EXCEPT negation, which
 714 we need to handle specially.
 715
 716 \begin{code}
 717 mkOpAppRn :: RenamedHsExpr                      -- Left operand; already rearranged
 718           -> RenamedHsExpr -> Fixity            -- Operator and fixity
 719           -> RenamedHsExpr                      -- Right operand (not an OpApp, but might
 720                                                 -- be a NegApp)
 721           -> RnM RenamedHsExpr
 722
 723 ---------------------------
 724 -- (e11 `op1` e12) `op2` e2
 725 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
 726   | nofix_error
 727   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
 728     returnM (OpApp e1 op2 fix2 e2)
 729
 730   | associate_right
 731   = mkOpAppRn e12 op2 fix2 e2           `thenM` \ new_e ->
 732     returnM (OpApp e11 op1 fix1 new_e)
 733   where
 734     (nofix_error, associate_right) = compareFixity fix1 fix2
 735
 736 ---------------------------
 737 --      (- neg_arg) `op` e2
 738 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
 739   | nofix_error
 740   = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))      `thenM_`
 741     returnM (OpApp e1 op2 fix2 e2)
 742
 743   | associate_right
 744   = mkOpAppRn neg_arg op2 fix2 e2       `thenM` \ new_e ->
 745     returnM (NegApp new_e neg_name)
 746   where
 747     (nofix_error, associate_right) = compareFixity negateFixity fix2
 748
 749 ---------------------------
 750 --      e1 `op` - neg_arg
 751 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _)     -- NegApp can occur on the right
 752   | not associate_right                         -- We *want* right association
 753   = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))    `thenM_`
 754     returnM (OpApp e1 op1 fix1 e2)
 755   where
 756     (_, associate_right) = compareFixity fix1 negateFixity
 757
 758 ---------------------------
 759 --      Default case
 760 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 761   = ASSERT2( right_op_ok fix e2,
 762              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
 763     )
 764     returnM (OpApp e1 op fix e2)
 765
 766 -- Parser left-associates everything, but
 767 -- derived instances may have correctly-associated things to
 768 -- in the right operarand.  So we just check that the right operand is OK
 769 right_op_ok fix1 (OpApp _ _ fix2 _)
 770   = not error_please && associate_right
 771   where
 772     (error_please, associate_right) = compareFixity fix1 fix2
 773 right_op_ok fix1 other
 774   = True
 775
 776 -- Parser initially makes negation bind more tightly than any other operator
 777 mkNegAppRn neg_arg neg_name
 778   =
 779 #ifdef DEBUG
 780     getModeRn                   `thenM` \ mode ->
 781     ASSERT( not_op_app mode neg_arg )
 782 #endif
 783     returnM (NegApp neg_arg neg_name)
 784
 785 not_op_app SourceMode (OpApp _ _ _ _) = False
 786 not_op_app mode other                 = True
 787 \end{code}
 788
 789 \begin{code}
 790 mkConOpPatRn :: Name -> Fixity -> RenamedPat -> RenamedPat
 791              -> RnM RenamedPat
 792
 793 mkConOpPatRn op2 fix2 p1@(ConPatIn op1 (InfixCon p11 p12)) p2
 794   = lookupFixityRn op1          `thenM` \ fix1 ->
 795     let
 796         (nofix_error, associate_right) = compareFixity fix1 fix2
 797     in
 798     if nofix_error then
 799         addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))       `thenM_`
 800         returnM (ConPatIn op2 (InfixCon p1 p2))
 801     else
 802     if associate_right then
 803         mkConOpPatRn op2 fix2 p12 p2            `thenM` \ new_p ->
 804         returnM (ConPatIn op1 (InfixCon p11 new_p))
 805     else
 806     returnM (ConPatIn op2 (InfixCon p1 p2))
 807
 808 mkConOpPatRn op fix p1 p2                       -- Default case, no rearrangment
 809   = ASSERT( not_op_pat p2 )
 810     returnM (ConPatIn op (InfixCon p1 p2))
 811
 812 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
 813 not_op_pat other                       = True
 814 \end{code}
 815
 816 \begin{code}
 817 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
 818
 819 checkPrecMatch False fn match
 820   = returnM ()
 821
 822 checkPrecMatch True op (Match (p1:p2:_) _ _)
 823         -- True indicates an infix lhs
 824   = getModeRn           `thenM` \ mode ->
 825         -- See comments with rnExpr (OpApp ...)
 826     if isInterfaceMode mode
 827         then returnM ()
 828         else checkPrec op p1 False      `thenM_`
 829              checkPrec op p2 True
 830
 831 checkPrecMatch True op _ = panic "checkPrecMatch"
 832
 833 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
 834   = lookupFixityRn op   `thenM` \  op_fix@(Fixity op_prec  op_dir) ->
 835     lookupFixityRn op1  `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
 836     let
 837         inf_ok = op1_prec > op_prec ||
 838                  (op1_prec == op_prec &&
 839                   (op1_dir == InfixR && op_dir == InfixR && right ||
 840                    op1_dir == InfixL && op_dir == InfixL && not right))
 841
 842         info  = (ppr_op op,  op_fix)
 843         info1 = (ppr_op op1, op1_fix)
 844         (infol, infor) = if right then (info, info1) else (info1, info)
 845     in
 846     checkErr inf_ok (precParseErr infol infor)
 847
 848 checkPrec op pat right
 849   = returnM ()
 850
 851 -- Check precedence of (arg op) or (op arg) respectively
 852 -- If arg is itself an operator application, then either
 853 --   (a) its precedence must be higher than that of op
 854 --   (b) its precedency & associativity must be the same as that of op
 855 checkSectionPrec direction section op arg
 856   = case arg of
 857         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
 858         NegApp _ _       -> go_for_it pp_prefix_minus negateFixity
 859         other            -> returnM ()
 860   where
 861     HsVar op_name = op
 862     go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
 863         = lookupFixityRn op_name        `thenM` \ op_fix@(Fixity op_prec _) ->
 864           checkErr (op_prec < arg_prec
 865                      || op_prec == arg_prec && direction == assoc)
 866                   (sectionPrecErr (ppr_op op_name, op_fix)
 867                   (pp_arg_op, arg_fix) section)
 868 \end{code}
 869
 870
 871 %************************************************************************
 872 %*                                                                      *
 873 \subsubsection{Literals}
 874 %*                                                                      *
 875 %************************************************************************
 876
 877 When literals occur we have to make sure
 878 that the types and classes they involve
 879 are made available.
 880
 881 \begin{code}
 882 litFVs (HsChar c)
 883    = checkErr (inCharRange c) (bogusCharError c) `thenM_`
 884      returnM (unitFV charTyCon_name)
 885
 886 litFVs (HsCharPrim c)         = returnM (unitFV (getName charPrimTyCon))
 887 litFVs (HsString s)           = returnM (mkFVs [listTyCon_name, charTyCon_name])
 888 litFVs (HsStringPrim s)       = returnM (unitFV (getName addrPrimTyCon))
 889 litFVs (HsInt i)              = returnM (unitFV (getName intTyCon))
 890 litFVs (HsIntPrim i)          = returnM (unitFV (getName intPrimTyCon))
 891 litFVs (HsFloatPrim f)        = returnM (unitFV (getName floatPrimTyCon))
 892 litFVs (HsDoublePrim d)       = returnM (unitFV (getName doublePrimTyCon))
 893 litFVs (HsLitLit l bogus_ty)  = returnM (unitFV cCallableClassName)
 894 litFVs lit                    = pprPanic "RnExpr.litFVs" (ppr lit)      -- HsInteger and HsRat only appear
 895                                                                         -- in post-typechecker translations
 896
 897 rnOverLit (HsIntegral i _)
 898   = lookupSyntaxName fromIntegerName    `thenM` \ (from_integer_name, fvs) ->
 899     if inIntRange i then
 900         returnM (HsIntegral i from_integer_name, fvs)
 901     else let
 902         extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
 903         -- Big integer literals are built, using + and *,
 904         -- out of small integers (DsUtils.mkIntegerLit)
 905         -- [NB: plusInteger, timesInteger aren't rebindable...
 906         --      they are used to construct the argument to fromInteger,
 907         --      which is the rebindable one.]
 908     in
 909     returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs)
 910
 911 rnOverLit (HsFractional i _)
 912   = lookupSyntaxName fromRationalName           `thenM` \ (from_rat_name, fvs) ->
 913     let
 914         extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
 915         -- We have to make sure that the Ratio type is imported with
 916         -- its constructor, because literals of type Ratio t are
 917         -- built with that constructor.
 918         -- The Rational type is needed too, but that will come in
 919         -- as part of the type for fromRational.
 920         -- The plus/times integer operations may be needed to construct the numerator
 921         -- and denominator (see DsUtils.mkIntegerLit)
 922     in
 923     returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
 924 \end{code}
 925
 926 %************************************************************************
 927 %*                                                                      *
 928 \subsubsection{Assertion utils}
 929 %*                                                                      *
 930 %************************************************************************
 931
 932 \begin{code}
 933 mkAssertExpr :: RnM (RenamedHsExpr, FreeVars)
 934 mkAssertExpr
 935   = getSrcLocM                          `thenM` \ sloc ->
 936
 937     -- if we're ignoring asserts, return (\ _ e -> e)
 938     -- if not, return (assertError "src-loc")
 939
 940     if opt_IgnoreAsserts then
 941       newUnique                         `thenM` \ uniq ->
 942       let
 943        vname = mkSystemName uniq FSLIT("v")
 944        expr  = HsLam ignorePredMatch
 945        loc   = nameSrcLoc vname
 946        ignorePredMatch = mkSimpleMatch [WildPat placeHolderType, VarPat vname]
 947                                        (HsVar vname) placeHolderType loc
 948       in
 949       returnM (expr, emptyFVs)
 950     else
 951       let
 952         expr =
 953           HsApp (HsVar assertName)
 954                 (HsLit (HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))))
 955       in
 956       returnM (expr, unitFV assertName)
 957 \end{code}
 958
 959 %************************************************************************
 960 %*                                                                      *
 961 \subsubsection{Errors}
 962 %*                                                                      *
 963 %************************************************************************
 964
 965 \begin{code}
 966 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
 967 pp_prefix_minus = ptext SLIT("prefix `-'")
 968
 969 dupFieldErr str (dup:rest)
 970   = hsep [ptext SLIT("duplicate field name"),
 971           quotes (ppr dup),
 972           ptext SLIT("in record"), text str]
 973
 974 nonStdGuardErr guard
 975   = hang (ptext
 976     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
 977     ) 4 (ppr guard)
 978
 979 patSigErr ty
 980   =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
 981         $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
 982
 983 patSynErr e
 984   = sep [ptext SLIT("Pattern syntax in expression context:"),
 985          nest 4 (ppr e)]
 986
 987 thErr what
 988   = ptext SLIT("Template Haskell") <+> text what <+>
 989     ptext SLIT("illegal in a stage-1 compiler")
 990
 991 doStmtListErr e
 992   = sep [ptext SLIT("`do' statements must end in expression:"),
 993          nest 4 (ppr e)]
 994
 995 bogusCharError c
 996   = ptext SLIT("character literal out of range: '\\") <> int c <> char '\''
 997
 998 withWarning
 999   = sep [quotes (ptext SLIT("with")),
1000          ptext SLIT("is deprecated, use"),
1001          quotes (ptext SLIT("let")),
1002          ptext SLIT("instead")]
1003 \end{code}