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