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