ghc/compiler/rename/RnExpr.lhs

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