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