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