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