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