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