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