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