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(..), mkSysLocalName, 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 "left" 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 "right" 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)
 380   = rnExpr expr                 `thenRn` \ (expr',fvExpr) ->
 381     rnIPBinds binds             `thenRn` \ (binds',fvBinds) ->
 382     returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
 383
 384 rnExpr e@(HsDo do_or_lc stmts src_loc)
 385   = pushSrcLocRn src_loc $
 386     rnStmts stmts                       `thenRn` \ ((_, stmts'), fvs) ->
 387         -- check the statement list ends in an expression
 388     case last stmts' of {
 389         ResultStmt _ _ -> returnRn () ;
 390         _              -> addErrRn (doStmtListErr e)
 391     }                                   `thenRn_`
 392     returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
 393   where
 394     implicit_fvs = case do_or_lc of
 395       PArrComp -> mkFVs [replicatePName, mapPName, filterPName,
 396                          falseDataConName, trueDataConName, crossPName,
 397                          zipPName]
 398       _        -> mkFVs [foldrName, buildName, monadClassName]
 399         -- Monad stuff should not be necessary for a list comprehension
 400         -- but the typechecker looks up the bind and return Ids anyway
 401         -- Oh well.
 402
 403 rnExpr (ExplicitList _ exps)
 404   = rnExprs exps                        `thenRn` \ (exps', fvs) ->
 405     returnRn  (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
 406
 407 rnExpr (ExplicitPArr _ exps)
 408   = rnExprs exps                        `thenRn` \ (exps', fvs) ->
 409     returnRn  (ExplicitPArr placeHolderType exps',
 410                fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
 411
 412 rnExpr (ExplicitTuple exps boxity)
 413   = rnExprs exps                                `thenRn` \ (exps', fvs) ->
 414     returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
 415   where
 416     tycon_name = tupleTyCon_name boxity (length exps)
 417
 418 rnExpr (RecordCon con_id rbinds)
 419   = lookupOccRn con_id                  `thenRn` \ conname ->
 420     rnRbinds "construction" rbinds      `thenRn` \ (rbinds', fvRbinds) ->
 421     returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
 422
 423 rnExpr (RecordUpd expr rbinds)
 424   = rnExpr expr                 `thenRn` \ (expr', fvExpr) ->
 425     rnRbinds "update" rbinds    `thenRn` \ (rbinds', fvRbinds) ->
 426     returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
 427
 428 rnExpr (ExprWithTySig expr pty)
 429   = rnExpr expr                                            `thenRn` \ (expr', fvExpr) ->
 430     rnHsTypeFVs (text "an expression type signature") pty  `thenRn` \ (pty', fvTy) ->
 431     returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
 432
 433 rnExpr (HsIf p b1 b2 src_loc)
 434   = pushSrcLocRn src_loc $
 435     rnExpr p            `thenRn` \ (p', fvP) ->
 436     rnExpr b1           `thenRn` \ (b1', fvB1) ->
 437     rnExpr b2           `thenRn` \ (b2', fvB2) ->
 438     returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
 439
 440 rnExpr (HsType a)
 441   = rnHsTypeFVs doc a   `thenRn` \ (t, fvT) ->
 442     returnRn (HsType t, fvT)
 443   where
 444     doc = text "renaming a type pattern"
 445
 446 rnExpr (ArithSeqIn seq)
 447   = rn_seq seq                          `thenRn` \ (new_seq, fvs) ->
 448     returnRn (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
 449   where
 450     rn_seq (From expr)
 451      = rnExpr expr      `thenRn` \ (expr', fvExpr) ->
 452        returnRn (From expr', fvExpr)
 453
 454     rn_seq (FromThen expr1 expr2)
 455      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 456        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 457        returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 458
 459     rn_seq (FromTo expr1 expr2)
 460      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 461        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 462        returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 463
 464     rn_seq (FromThenTo expr1 expr2 expr3)
 465      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 466        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 467        rnExpr expr3     `thenRn` \ (expr3', fvExpr3) ->
 468        returnRn (FromThenTo expr1' expr2' expr3',
 469                   plusFVs [fvExpr1, fvExpr2, fvExpr3])
 470
 471 rnExpr (PArrSeqIn seq)
 472   = rn_seq seq                         `thenRn` \ (new_seq, fvs) ->
 473     returnRn (PArrSeqIn new_seq,
 474               fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
 475   where
 476
 477     -- the parser shouldn't generate these two
 478     --
 479     rn_seq (From     _  ) = panic "RnExpr.rnExpr: Infinite parallel array!"
 480     rn_seq (FromThen _ _) = panic "RnExpr.rnExpr: Infinite parallel array!"
 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     rn_seq (FromThenTo expr1 expr2 expr3)
 487      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 488        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 489        rnExpr expr3     `thenRn` \ (expr3', fvExpr3) ->
 490        returnRn (FromThenTo expr1' expr2' expr3',
 491                   plusFVs [fvExpr1, fvExpr2, fvExpr3])
 492 \end{code}
 493
 494 These three are pattern syntax appearing in expressions.
 495 Since all the symbols are reservedops we can simply reject them.
 496 We return a (bogus) EWildPat in each case.
 497
 498 \begin{code}
 499 rnExpr e@EWildPat = addErrRn (patSynErr e)      `thenRn_`
 500                     returnRn (EWildPat, emptyFVs)
 501
 502 rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e)  `thenRn_`
 503                         returnRn (EWildPat, emptyFVs)
 504
 505 rnExpr e@(ELazyPat _) = addErrRn (patSynErr e)  `thenRn_`
 506                         returnRn (EWildPat, emptyFVs)
 507 \end{code}
 508
 509
 510
 511 %************************************************************************
 512 %*                                                                      *
 513 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 514 %*                                                                      *
 515 %************************************************************************
 516
 517 \begin{code}
 518 rnRbinds str rbinds
 519   = mapRn_ field_dup_err dup_fields     `thenRn_`
 520     mapFvRn rn_rbind rbinds             `thenRn` \ (rbinds', fvRbind) ->
 521     returnRn (rbinds', fvRbind)
 522   where
 523     (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
 524
 525     field_dup_err dups = addErrRn (dupFieldErr str dups)
 526
 527     rn_rbind (field, expr, pun)
 528       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 529         rnExpr expr             `thenRn` \ (expr', fvExpr) ->
 530         returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
 531
 532 rnRpats rpats
 533   = mapRn_ field_dup_err dup_fields     `thenRn_`
 534     mapFvRn rn_rpat rpats               `thenRn` \ (rpats', fvs) ->
 535     returnRn (rpats', fvs)
 536   where
 537     (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
 538
 539     field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
 540
 541     rn_rpat (field, pat, pun)
 542       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 543         rnPat pat               `thenRn` \ (pat', fvs) ->
 544         returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
 545 \end{code}
 546
 547 %************************************************************************
 548 %*                                                                      *
 549 \subsubsection{@rnIPBinds@s: in implicit parameter bindings}            *
 550 %*                                                                      *
 551 %************************************************************************
 552
 553 \begin{code}
 554 rnIPBinds [] = returnRn ([], emptyFVs)
 555 rnIPBinds ((n, expr) : binds)
 556   = newIPName n                 `thenRn` \ name ->
 557     rnExpr expr                 `thenRn` \ (expr',fvExpr) ->
 558     rnIPBinds binds             `thenRn` \ (binds',fvBinds) ->
 559     returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
 560
 561 \end{code}
 562
 563 %************************************************************************
 564 %*                                                                      *
 565 \subsubsection{@Stmt@s: in @do@ expressions}
 566 %*                                                                      *
 567 %************************************************************************
 568
 569 Note that although some bound vars may appear in the free var set for
 570 the first qual, these will eventually be removed by the caller. For
 571 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
 572 @[q <- r, p <- q]@, the free var set for @q <- r@ will
 573 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 574 @r@ will be removed only when we finally return from examining all the
 575 Quals.
 576
 577 \begin{code}
 578 rnStmts :: [RdrNameStmt]
 579         -> RnMS (([Name], [RenamedStmt]), FreeVars)
 580
 581 rnStmts []
 582   = returnRn (([], []), emptyFVs)
 583
 584 rnStmts (stmt:stmts)
 585   = getLocalNameEnv             `thenRn` \ name_env ->
 586     rnStmt stmt                         $ \ stmt' ->
 587     rnStmts stmts                       `thenRn` \ ((binders, stmts'), fvs) ->
 588     returnRn ((binders, stmt' : stmts'), fvs)
 589
 590 rnStmt :: RdrNameStmt
 591        -> (RenamedStmt -> RnMS (([Name], a), FreeVars))
 592        -> RnMS (([Name], a), FreeVars)
 593 -- The thing list of names returned is the list returned by the
 594 -- thing_inside, plus the binders of the arguments stmt
 595
 596 -- Because of mutual recursion we have to pass in rnExpr.
 597
 598 rnStmt (ParStmt stmtss) thing_inside
 599   = mapFvRn rnStmts stmtss              `thenRn` \ (bndrstmtss, fv_stmtss) ->
 600     let binderss = map fst bndrstmtss
 601         checkBndrs all_bndrs bndrs
 602           = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_`
 603             returnRn (bndrs ++ all_bndrs)
 604         eqOcc n1 n2 = nameOccName n1 == nameOccName n2
 605         err = text "duplicate binding in parallel list comprehension"
 606     in
 607     foldlRn checkBndrs [] binderss      `thenRn` \ new_binders ->
 608     bindLocalNamesFV new_binders        $
 609     thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) ->
 610     returnRn ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest)
 611
 612 rnStmt (BindStmt pat expr src_loc) thing_inside
 613   = pushSrcLocRn src_loc $
 614     rnExpr expr                                 `thenRn` \ (expr', fv_expr) ->
 615     bindPatSigTyVars (collectSigTysFromPat pat) $
 616     bindLocalsFVRn doc (collectPatBinders pat)  $ \ new_binders ->
 617     rnPat pat                                   `thenRn` \ (pat', fv_pat) ->
 618     thing_inside (BindStmt pat' expr' src_loc)  `thenRn` \ ((rest_binders, result), fvs) ->
 619     returnRn ((new_binders ++ rest_binders, result),
 620               fv_expr `plusFV` fvs `plusFV` fv_pat)
 621   where
 622     doc = text "In a pattern in 'do' binding"
 623
 624 rnStmt (ExprStmt expr _ src_loc) thing_inside
 625   = pushSrcLocRn src_loc $
 626     rnExpr expr                                                 `thenRn` \ (expr', fv_expr) ->
 627     thing_inside (ExprStmt expr' placeHolderType src_loc)       `thenRn` \ (result, fvs) ->
 628     returnRn (result, fv_expr `plusFV` fvs)
 629
 630 rnStmt (ResultStmt expr src_loc) thing_inside
 631   = pushSrcLocRn src_loc $
 632     rnExpr expr                                 `thenRn` \ (expr', fv_expr) ->
 633     thing_inside (ResultStmt expr' src_loc)     `thenRn` \ (result, fvs) ->
 634     returnRn (result, fv_expr `plusFV` fvs)
 635
 636 rnStmt (LetStmt binds) thing_inside
 637   = rnBinds binds                               $ \ binds' ->
 638     let new_binders = collectHsBinders binds' in
 639     thing_inside (LetStmt binds')    `thenRn` \ ((rest_binders, result), fvs) ->
 640     returnRn ((new_binders ++ rest_binders, result), fvs )
 641 \end{code}
 642
 643 %************************************************************************
 644 %*                                                                      *
 645 \subsubsection{Precedence Parsing}
 646 %*                                                                      *
 647 %************************************************************************
 648
 649 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 650 are assumed to be already correctly arranged.  It needs the fixities
 651 recorded in the OpApp nodes, because fixity info applies to the things
 652 the programmer actually wrote, so you can't find it out from the Name.
 653
 654 Furthermore, the second argument is guaranteed not to be another
 655 operator application.  Why? Because the parser parses all
 656 operator appications left-associatively, EXCEPT negation, which
 657 we need to handle specially.
 658
 659 \begin{code}
 660 mkOpAppRn :: RenamedHsExpr                      -- Left operand; already rearranged
 661           -> RenamedHsExpr -> Fixity            -- Operator and fixity
 662           -> RenamedHsExpr                      -- Right operand (not an OpApp, but might
 663                                                 -- be a NegApp)
 664           -> RnMS RenamedHsExpr
 665
 666 ---------------------------
 667 -- (e11 `op1` e12) `op2` e2
 668 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
 669   | nofix_error
 670   = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
 671     returnRn (OpApp e1 op2 fix2 e2)
 672
 673   | associate_right
 674   = mkOpAppRn e12 op2 fix2 e2           `thenRn` \ new_e ->
 675     returnRn (OpApp e11 op1 fix1 new_e)
 676   where
 677     (nofix_error, associate_right) = compareFixity fix1 fix2
 678
 679 ---------------------------
 680 --      (- neg_arg) `op` e2
 681 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
 682   | nofix_error
 683   = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))    `thenRn_`
 684     returnRn (OpApp e1 op2 fix2 e2)
 685
 686   | associate_right
 687   = mkOpAppRn neg_arg op2 fix2 e2       `thenRn` \ new_e ->
 688     returnRn (NegApp new_e neg_name)
 689   where
 690     (nofix_error, associate_right) = compareFixity negateFixity fix2
 691
 692 ---------------------------
 693 --      e1 `op` - neg_arg
 694 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _)     -- NegApp can occur on the right
 695   | not associate_right                         -- We *want* right association
 696   = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))  `thenRn_`
 697     returnRn (OpApp e1 op1 fix1 e2)
 698   where
 699     (_, associate_right) = compareFixity fix1 negateFixity
 700
 701 ---------------------------
 702 --      Default case
 703 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 704   = ASSERT2( right_op_ok fix e2,
 705              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
 706     )
 707     returnRn (OpApp e1 op fix e2)
 708
 709 -- Parser left-associates everything, but
 710 -- derived instances may have correctly-associated things to
 711 -- in the right operarand.  So we just check that the right operand is OK
 712 right_op_ok fix1 (OpApp _ _ fix2 _)
 713   = not error_please && associate_right
 714   where
 715     (error_please, associate_right) = compareFixity fix1 fix2
 716 right_op_ok fix1 other
 717   = True
 718
 719 -- Parser initially makes negation bind more tightly than any other operator
 720 mkNegAppRn neg_arg neg_name
 721   =
 722 #ifdef DEBUG
 723     getModeRn                   `thenRn` \ mode ->
 724     ASSERT( not_op_app mode neg_arg )
 725 #endif
 726     returnRn (NegApp neg_arg neg_name)
 727
 728 not_op_app SourceMode (OpApp _ _ _ _) = False
 729 not_op_app mode other                 = True
 730 \end{code}
 731
 732 \begin{code}
 733 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
 734              -> RnMS RenamedPat
 735
 736 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
 737              op2 fix2 p2
 738   | nofix_error
 739   = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
 740     returnRn (ConOpPatIn p1 op2 fix2 p2)
 741
 742   | associate_right
 743   = mkConOpPatRn p12 op2 fix2 p2                `thenRn` \ new_p ->
 744     returnRn (ConOpPatIn p11 op1 fix1 new_p)
 745
 746   where
 747     (nofix_error, associate_right) = compareFixity fix1 fix2
 748
 749 mkConOpPatRn p1 op fix p2                       -- Default case, no rearrangment
 750   = ASSERT( not_op_pat p2 )
 751     returnRn (ConOpPatIn p1 op fix p2)
 752
 753 not_op_pat (ConOpPatIn _ _ _ _) = False
 754 not_op_pat other                = True
 755 \end{code}
 756
 757 \begin{code}
 758 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
 759
 760 checkPrecMatch False fn match
 761   = returnRn ()
 762
 763 checkPrecMatch True op (Match (p1:p2:_) _ _)
 764         -- True indicates an infix lhs
 765   = getModeRn           `thenRn` \ mode ->
 766         -- See comments with rnExpr (OpApp ...)
 767     if isInterfaceMode mode
 768         then returnRn ()
 769         else checkPrec op p1 False      `thenRn_`
 770              checkPrec op p2 True
 771
 772 checkPrecMatch True op _ = panic "checkPrecMatch"
 773
 774 checkPrec op (ConOpPatIn _ op1 _ _) right
 775   = lookupFixityRn op   `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
 776     lookupFixityRn op1  `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
 777     let
 778         inf_ok = op1_prec > op_prec ||
 779                  (op1_prec == op_prec &&
 780                   (op1_dir == InfixR && op_dir == InfixR && right ||
 781                    op1_dir == InfixL && op_dir == InfixL && not right))
 782
 783         info  = (ppr_op op,  op_fix)
 784         info1 = (ppr_op op1, op1_fix)
 785         (infol, infor) = if right then (info, info1) else (info1, info)
 786     in
 787     checkRn inf_ok (precParseErr infol infor)
 788
 789 checkPrec op pat right
 790   = returnRn ()
 791
 792 -- Check precedence of (arg op) or (op arg) respectively
 793 -- If arg is itself an operator application, its precedence should
 794 -- be higher than that of op
 795 checkSectionPrec left_or_right section op arg
 796   = case arg of
 797         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
 798         NegApp _ _       -> go_for_it pp_prefix_minus negateFixity
 799         other            -> returnRn ()
 800   where
 801     HsVar op_name = op
 802     go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
 803         = lookupFixityRn op_name        `thenRn` \ op_fix@(Fixity op_prec _) ->
 804           checkRn (op_prec < arg_prec)
 805                   (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
 806 \end{code}
 807
 808 Consider
 809 \begin{verbatim}
 810         a `op1` b `op2` c
 811 \end{verbatim}
 812 @(compareFixity op1 op2)@ tells which way to arrange appication, or
 813 whether there's an error.
 814
 815 \begin{code}
 816 compareFixity :: Fixity -> Fixity
 817               -> (Bool,         -- Error please
 818                   Bool)         -- Associate to the right: a op1 (b op2 c)
 819 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
 820   = case prec1 `compare` prec2 of
 821         GT -> left
 822         LT -> right
 823         EQ -> case (dir1, dir2) of
 824                         (InfixR, InfixR) -> right
 825                         (InfixL, InfixL) -> left
 826                         _                -> error_please
 827   where
 828     right        = (False, True)
 829     left         = (False, False)
 830     error_please = (True,  False)
 831 \end{code}
 832
 833 %************************************************************************
 834 %*                                                                      *
 835 \subsubsection{Literals}
 836 %*                                                                      *
 837 %************************************************************************
 838
 839 When literals occur we have to make sure
 840 that the types and classes they involve
 841 are made available.
 842
 843 \begin{code}
 844 litFVs (HsChar c)
 845    = checkRn (inCharRange c) (bogusCharError c) `thenRn_`
 846      returnRn (unitFV charTyCon_name)
 847
 848 litFVs (HsCharPrim c)         = returnRn (unitFV (getName charPrimTyCon))
 849 litFVs (HsString s)           = returnRn (mkFVs [listTyCon_name, charTyCon_name])
 850 litFVs (HsStringPrim s)       = returnRn (unitFV (getName addrPrimTyCon))
 851 litFVs (HsInt i)              = returnRn (unitFV (getName intTyCon))
 852 litFVs (HsIntPrim i)          = returnRn (unitFV (getName intPrimTyCon))
 853 litFVs (HsFloatPrim f)        = returnRn (unitFV (getName floatPrimTyCon))
 854 litFVs (HsDoublePrim d)       = returnRn (unitFV (getName doublePrimTyCon))
 855 litFVs (HsLitLit l bogus_ty)  = returnRn (unitFV cCallableClassName)
 856 litFVs lit                    = pprPanic "RnExpr.litFVs" (ppr lit)      -- HsInteger and HsRat only appear
 857                                                                         -- in post-typechecker translations
 858
 859 rnOverLit (HsIntegral i from_integer_name)
 860   = lookupSyntaxName from_integer_name  `thenRn` \ from_integer_name' ->
 861     if inIntRange i then
 862         returnRn (HsIntegral i from_integer_name', unitFV from_integer_name')
 863     else let
 864         fvs = mkFVs [plusIntegerName, timesIntegerName]
 865         -- Big integer literals are built, using + and *,
 866         -- out of small integers (DsUtils.mkIntegerLit)
 867         -- [NB: plusInteger, timesInteger aren't rebindable...
 868         --      they are used to construct the argument to fromInteger,
 869         --      which is the rebindable one.]
 870     in
 871     returnRn (HsIntegral i from_integer_name', fvs `addOneFV` from_integer_name')
 872
 873 rnOverLit (HsFractional i from_rat_name)
 874   = lookupSyntaxName from_rat_name                                              `thenRn` \ from_rat_name' ->
 875     let
 876         fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
 877         -- We have to make sure that the Ratio type is imported with
 878         -- its constructor, because literals of type Ratio t are
 879         -- built with that constructor.
 880         -- The Rational type is needed too, but that will come in
 881         -- when fractionalClass does.
 882         -- The plus/times integer operations may be needed to construct the numerator
 883         -- and denominator (see DsUtils.mkIntegerLit)
 884     in
 885     returnRn (HsFractional i from_rat_name', fvs `addOneFV` from_rat_name')
 886 \end{code}
 887
 888 %************************************************************************
 889 %*                                                                      *
 890 \subsubsection{Assertion utils}
 891 %*                                                                      *
 892 %************************************************************************
 893
 894 \begin{code}
 895 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
 896 mkAssertExpr =
 897   lookupOrigName assertErr_RDR          `thenRn` \ name ->
 898   getSrcLocRn                           `thenRn` \ sloc ->
 899
 900     -- if we're ignoring asserts, return (\ _ e -> e)
 901     -- if not, return (assertError "src-loc")
 902
 903   if opt_IgnoreAsserts then
 904     getUniqRn                           `thenRn` \ uniq ->
 905     let
 906      vname = mkSysLocalName uniq SLIT("v")
 907      expr  = HsLam ignorePredMatch
 908      loc   = nameSrcLoc vname
 909      ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) placeHolderType loc
 910     in
 911     returnRn (expr, unitFV name)
 912   else
 913     let
 914      expr =
 915           HsApp (HsVar name)
 916                 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
 917
 918     in
 919     returnRn (expr, unitFV name)
 920
 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 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
 932 pp_prefix_minus = ptext SLIT("prefix `-'")
 933
 934 dupFieldErr str (dup:rest)
 935   = hsep [ptext SLIT("duplicate field name"),
 936           quotes (ppr dup),
 937           ptext SLIT("in record"), text str]
 938
 939 precParseErr op1 op2
 940   = hang (ptext SLIT("precedence parsing error"))
 941       4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
 942                ppr_opfix op2,
 943                ptext SLIT("in the same infix expression")])
 944
 945 sectionPrecErr op arg_op section
 946  = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
 947          nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
 948          nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
 949
 950 nonStdGuardErr guard
 951   = hang (ptext
 952     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
 953     ) 4 (ppr guard)
 954
 955 patSigErr ty
 956   =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
 957         $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
 958
 959 patSynErr e
 960   = sep [ptext SLIT("Pattern syntax in expression context:"),
 961          nest 4 (ppr e)]
 962
 963 doStmtListErr e
 964   = sep [ptext SLIT("`do' statements must end in expression:"),
 965          nest 4 (ppr e)]
 966
 967 bogusCharError c
 968   = ptext SLIT("character literal out of range: '\\") <> int c <> char '\''
 969 \end{code}