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