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