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