ghc/compiler/rename/RnExpr.lhs

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