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