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