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