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