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