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@, @GRHSsAndBinds@, @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, rnGRHSsAndBinds, rnPat,
  15         checkPrecMatch
  16    ) where
  17
  18 #include "HsVersions.h"
  19
  20 import {-# SOURCE #-} RnBinds  ( rnBinds )
  21 import {-# SOURCE #-} RnSource ( rnHsSigType )
  22
  23 import HsSyn
  24 import RdrHsSyn
  25 import RnHsSyn
  26 import RnMonad
  27 import RnEnv
  28 import CmdLineOpts      ( opt_GlasgowExts )
  29 import BasicTypes       ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
  30 import PrelInfo         ( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
  31                           ccallableClass_RDR, creturnableClass_RDR,
  32                           monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
  33                           ratioDataCon_RDR, negate_RDR, assertErr_RDR,
  34                           ioDataCon_RDR
  35                         )
  36 import TysPrim          ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
  37                           floatPrimTyCon, doublePrimTyCon
  38                         )
  39 import Name             ( nameUnique, isLocallyDefined, NamedThing(..) )
  40 import NameSet
  41 import UniqFM           ( isNullUFM )
  42 import UniqSet          ( emptyUniqSet, UniqSet )
  43 import Unique           ( assertIdKey )
  44 import Util             ( removeDups )
  45 import Outputable
  46 \end{code}
  47
  48
  49 *********************************************************
  50 *                                                       *
  51 \subsection{Patterns}
  52 *                                                       *
  53 *********************************************************
  54
  55 \begin{code}
  56 rnPat :: RdrNamePat -> RnMS s RenamedPat
  57
  58 rnPat WildPatIn = returnRn WildPatIn
  59
  60 rnPat (VarPatIn name)
  61   = lookupBndrRn  name                  `thenRn` \ vname ->
  62     returnRn (VarPatIn vname)
  63
  64 rnPat (LitPatIn lit)
  65   = litOccurrence lit                   `thenRn_`
  66     lookupImplicitOccRn eqClass_RDR     `thenRn_`       -- Needed to find equality on pattern
  67     returnRn (LitPatIn lit)
  68
  69 rnPat (LazyPatIn pat)
  70   = rnPat pat           `thenRn` \ pat' ->
  71     returnRn (LazyPatIn pat')
  72
  73 rnPat (AsPatIn name pat)
  74   = rnPat pat           `thenRn` \ pat' ->
  75     lookupBndrRn name   `thenRn` \ vname ->
  76     returnRn (AsPatIn vname pat')
  77
  78 rnPat (ConPatIn con pats)
  79   = lookupOccRn con     `thenRn` \ con' ->
  80     mapRn rnPat pats    `thenRn` \ patslist ->
  81     returnRn (ConPatIn con' patslist)
  82
  83 rnPat (ConOpPatIn pat1 con _ pat2)
  84   = rnPat pat1          `thenRn` \ pat1' ->
  85     lookupOccRn con     `thenRn` \ con' ->
  86     lookupFixity con    `thenRn` \ fixity ->
  87     rnPat pat2          `thenRn` \ pat2' ->
  88     mkConOpPatRn pat1' con' fixity pat2'
  89
  90 -- Negated patters can only be literals, and they are dealt with
  91 -- by negating the literal at compile time, not by using the negation
  92 -- operation in Num.  So we don't need to make an implicit reference
  93 -- to negate_RDR.
  94 rnPat neg@(NegPatIn pat)
  95   = checkRn (valid_neg_pat pat) (negPatErr neg)
  96                         `thenRn_`
  97     rnPat pat           `thenRn` \ pat' ->
  98     returnRn (NegPatIn pat')
  99   where
 100     valid_neg_pat (LitPatIn (HsInt  _)) = True
 101     valid_neg_pat (LitPatIn (HsFrac _)) = True
 102     valid_neg_pat _                     = False
 103
 104 rnPat (ParPatIn pat)
 105   = rnPat pat           `thenRn` \ pat' ->
 106     returnRn (ParPatIn pat')
 107
 108 rnPat (NPlusKPatIn name lit)
 109   = litOccurrence lit                   `thenRn_`
 110     lookupImplicitOccRn ordClass_RDR    `thenRn_`
 111     lookupBndrRn name                   `thenRn` \ name' ->
 112     returnRn (NPlusKPatIn name' lit)
 113
 114 rnPat (ListPatIn pats)
 115   = addImplicitOccRn listTyCon_name     `thenRn_`
 116     mapRn rnPat pats                    `thenRn` \ patslist ->
 117     returnRn (ListPatIn patslist)
 118
 119 rnPat (TuplePatIn pats boxed)
 120   = addImplicitOccRn (tupleTyCon_name boxed (length pats)) `thenRn_`
 121     mapRn rnPat pats                                    `thenRn` \ patslist ->
 122     returnRn (TuplePatIn patslist boxed)
 123
 124 rnPat (RecPatIn con rpats)
 125   = lookupOccRn con     `thenRn` \ con' ->
 126     rnRpats rpats       `thenRn` \ rpats' ->
 127     returnRn (RecPatIn con' rpats')
 128 \end{code}
 129
 130 ************************************************************************
 131 *                                                                       *
 132 \subsection{Match}
 133 *                                                                       *
 134 ************************************************************************
 135
 136 \begin{code}
 137 rnMatch, rnMatch1 :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
 138
 139 -- The only tricky bit here is that we want to do a single
 140 -- bindLocalsRn for all the matches together, so that we spot
 141 -- the repeated variable in
 142 --      f x x = 1
 143
 144 rnMatch match
 145   = pushSrcLocRn (getMatchLoc match) $
 146     bindLocalsRn "pattern" (get_binders match)  $ \ new_binders ->
 147     rnMatch1 match                              `thenRn` \ (match', fvs) ->
 148     let
 149         binder_set     = mkNameSet new_binders
 150         unused_binders = binder_set `minusNameSet` fvs
 151         net_fvs        = fvs `minusNameSet` binder_set
 152     in
 153     warnUnusedMatches unused_binders            `thenRn_`
 154
 155     returnRn (match', net_fvs)
 156  where
 157     get_binders (GRHSMatch _)        = []
 158     get_binders (PatMatch pat match) = collectPatBinders pat ++ get_binders match
 159
 160 rnMatch1 (PatMatch pat match)
 161   = rnPat pat                           `thenRn` \ pat' ->
 162     rnMatch1 match                      `thenRn` \ (match', fvs) ->
 163     returnRn (PatMatch pat' match', fvs)
 164
 165 rnMatch1 (GRHSMatch grhss_and_binds)
 166   = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
 167     returnRn (GRHSMatch grhss_and_binds', fvs)
 168 \end{code}
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 \begin{code}
 177 rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
 178
 179 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
 180   = rnBinds binds               $ \ binds' ->
 181     rnGRHSs grhss               `thenRn` \ (grhss', fvGRHS) ->
 182     returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS)
 183   where
 184     rnGRHSs [] = returnRn ([], emptyNameSet)
 185
 186     rnGRHSs (grhs:grhss)
 187       = rnGRHS  grhs   `thenRn` \ (grhs',  fvs) ->
 188         rnGRHSs grhss  `thenRn` \ (grhss', fvss) ->
 189         returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
 190
 191     rnGRHS (GRHS guarded locn)
 192       = pushSrcLocRn locn $
 193         (if not (opt_GlasgowExts || is_standard_guard guarded) then
 194                 addWarnRn (nonStdGuardErr guarded)
 195          else
 196                 returnRn ()
 197         )               `thenRn_`
 198
 199         rnStmts rnExpr guarded  `thenRn` \ (guarded', fvs) ->
 200         returnRn (GRHS guarded' locn, fvs)
 201
 202         -- Standard Haskell 1.4 guards are just a single boolean
 203         -- expression, rather than a list of qualifiers as in the
 204         -- Glasgow extension
 205     is_standard_guard [ExprStmt _ _]                = True
 206     is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True
 207     is_standard_guard other                         = False
 208 \end{code}
 209
 210 %************************************************************************
 211 %*                                                                      *
 212 \subsubsection{Expressions}
 213 %*                                                                      *
 214 %************************************************************************
 215
 216 \begin{code}
 217 rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
 218 rnExprs ls = rnExprs' ls emptyUniqSet
 219  where
 220   rnExprs' [] acc = returnRn ([], acc)
 221   rnExprs' (expr:exprs) acc
 222    = rnExpr expr                `thenRn` \ (expr', fvExpr) ->
 223
 224         -- Now we do a "seq" on the free vars because typically it's small
 225         -- or empty, especially in very long lists of constants
 226     let
 227         acc' = acc `unionNameSets` fvExpr
 228     in
 229     (grubby_seqNameSet acc' rnExprs') exprs acc'        `thenRn` \ (exprs', fvExprs) ->
 230     returnRn (expr':exprs', fvExprs)
 231
 232 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
 233 grubby_seqNameSet ns result | isNullUFM ns = result
 234                             | otherwise    = result
 235 \end{code}
 236
 237 Variables. We look up the variable and return the resulting name.  The
 238 interesting question is what the free-variable set should be.  We
 239 don't want to return imported or prelude things as free vars.  So we
 240 look at the Name returned from the lookup, and make it part of the
 241 free-var set iff if it's a LocallyDefined Name.
 242 \end{itemize}
 243
 244 \begin{code}
 245 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 246
 247 rnExpr (HsVar v)
 248   = lookupOccRn v       `thenRn` \ name ->
 249     if nameUnique name == assertIdKey then
 250         -- We expand it to (GHCerr.assert__ location)
 251         mkAssertExpr  `thenRn` \ expr ->
 252         returnRn (expr, emptyUniqSet)
 253     else
 254         -- The normal case
 255        returnRn (HsVar name, if isLocallyDefined name
 256                              then unitNameSet name
 257                              else emptyUniqSet)
 258
 259 rnExpr (HsLit lit)
 260   = litOccurrence lit           `thenRn_`
 261     returnRn (HsLit lit, emptyNameSet)
 262
 263 rnExpr (HsLam match)
 264   = rnMatch match       `thenRn` \ (match', fvMatch) ->
 265     returnRn (HsLam match', fvMatch)
 266
 267 rnExpr (HsApp fun arg)
 268   = rnExpr fun          `thenRn` \ (fun',fvFun) ->
 269     rnExpr arg          `thenRn` \ (arg',fvArg) ->
 270     returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
 271
 272 rnExpr (OpApp e1 op@(HsVar op_name) _ e2)
 273   = rnExpr e1                           `thenRn` \ (e1', fv_e1) ->
 274     rnExpr e2                           `thenRn` \ (e2', fv_e2) ->
 275     rnExpr op                           `thenRn` \ (op', fv_op) ->
 276
 277         -- Deal with fixity
 278         -- When renaming code synthesised from "deriving" declarations
 279         -- we're in Interface mode, and we should ignore fixity; assume
 280         -- that the deriving code generator got the association correct
 281     lookupFixity op_name                `thenRn` \ fixity ->
 282     getModeRn                           `thenRn` \ mode ->
 283     (case mode of
 284         SourceMode        -> mkOpAppRn e1' op' fixity e2'
 285         InterfaceMode _ _ -> returnRn (OpApp e1' op' fixity e2')
 286     )                                   `thenRn` \ final_e ->
 287
 288     returnRn (final_e,
 289               fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2)
 290
 291 rnExpr (NegApp e n)
 292   = rnExpr e                            `thenRn` \ (e', fv_e) ->
 293     lookupImplicitOccRn negate_RDR      `thenRn` \ neg ->
 294     mkNegAppRn e' (HsVar neg)           `thenRn` \ final_e ->
 295     returnRn (final_e, fv_e)
 296
 297 rnExpr (HsPar e)
 298   = rnExpr e            `thenRn` \ (e', fvs_e) ->
 299     returnRn (HsPar e', fvs_e)
 300
 301 rnExpr (SectionL expr op)
 302   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 303     rnExpr op           `thenRn` \ (op', fvs_op) ->
 304     returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
 305
 306 rnExpr (SectionR op expr)
 307   = rnExpr op           `thenRn` \ (op',   fvs_op) ->
 308     rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 309     returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
 310
 311 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
 312         -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
 313   = lookupImplicitOccRn ccallableClass_RDR      `thenRn_`
 314     lookupImplicitOccRn creturnableClass_RDR    `thenRn_`
 315     lookupImplicitOccRn ioDataCon_RDR           `thenRn_`
 316     rnExprs args                                `thenRn` \ (args', fvs_args) ->
 317     returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
 318
 319 rnExpr (HsSCC label expr)
 320   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 321     returnRn (HsSCC label expr', fvs_expr)
 322
 323 rnExpr (HsCase expr ms src_loc)
 324   = pushSrcLocRn src_loc $
 325     rnExpr expr                 `thenRn` \ (new_expr, e_fvs) ->
 326     mapAndUnzipRn rnMatch ms    `thenRn` \ (new_ms, ms_fvs) ->
 327     returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
 328
 329 rnExpr (HsLet binds expr)
 330   = rnBinds binds               $ \ binds' ->
 331     rnExpr expr                  `thenRn` \ (expr',fvExpr) ->
 332     returnRn (HsLet binds' expr', fvExpr)
 333
 334 rnExpr (HsDo do_or_lc stmts src_loc)
 335   = pushSrcLocRn src_loc $
 336     lookupImplicitOccRn monadZeroClass_RDR      `thenRn_`       -- Forces Monad to come too
 337     rnStmts rnExpr stmts                        `thenRn` \ (stmts', fvs) ->
 338     returnRn (HsDo do_or_lc stmts' src_loc, fvs)
 339
 340 rnExpr (ExplicitList exps)
 341   = addImplicitOccRn listTyCon_name     `thenRn_`
 342     rnExprs exps                        `thenRn` \ (exps', fvs) ->
 343     returnRn  (ExplicitList exps', fvs)
 344
 345 rnExpr (ExplicitTuple exps boxed)
 346   = addImplicitOccRn (tupleTyCon_name boxed (length exps)) `thenRn_`
 347     rnExprs exps                                `thenRn` \ (exps', fvExps) ->
 348     returnRn (ExplicitTuple exps' boxed, fvExps)
 349
 350 rnExpr (RecordCon con_id rbinds)
 351   = lookupOccRn con_id                  `thenRn` \ conname ->
 352     rnRbinds "construction" rbinds      `thenRn` \ (rbinds', fvRbinds) ->
 353     returnRn (RecordCon conname rbinds', fvRbinds)
 354
 355 rnExpr (RecordUpd expr rbinds)
 356   = rnExpr expr                 `thenRn` \ (expr', fvExpr) ->
 357     rnRbinds "update" rbinds    `thenRn` \ (rbinds', fvRbinds) ->
 358     returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
 359
 360 rnExpr (ExprWithTySig expr pty)
 361   = rnExpr expr                                 `thenRn` \ (expr', fvExpr) ->
 362     rnHsSigType (text "an expression") pty      `thenRn` \ pty' ->
 363     returnRn (ExprWithTySig expr' pty', fvExpr)
 364
 365 rnExpr (HsIf p b1 b2 src_loc)
 366   = pushSrcLocRn src_loc $
 367     rnExpr p            `thenRn` \ (p', fvP) ->
 368     rnExpr b1           `thenRn` \ (b1', fvB1) ->
 369     rnExpr b2           `thenRn` \ (b2', fvB2) ->
 370     returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
 371
 372 rnExpr (ArithSeqIn seq)
 373   = lookupImplicitOccRn enumClass_RDR   `thenRn_`
 374     rn_seq seq                          `thenRn` \ (new_seq, fvs) ->
 375     returnRn (ArithSeqIn new_seq, fvs)
 376   where
 377     rn_seq (From expr)
 378      = rnExpr expr      `thenRn` \ (expr', fvExpr) ->
 379        returnRn (From expr', fvExpr)
 380
 381     rn_seq (FromThen expr1 expr2)
 382      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 383        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 384        returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 385
 386     rn_seq (FromTo expr1 expr2)
 387      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 388        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 389        returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 390
 391     rn_seq (FromThenTo expr1 expr2 expr3)
 392      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 393        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 394        rnExpr expr3     `thenRn` \ (expr3', fvExpr3) ->
 395        returnRn (FromThenTo expr1' expr2' expr3',
 396                   unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
 397 \end{code}
 398
 399 %************************************************************************
 400 %*                                                                      *
 401 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 402 %*                                                                      *
 403 %************************************************************************
 404
 405 \begin{code}
 406 rnRbinds str rbinds
 407   = mapRn field_dup_err dup_fields      `thenRn_`
 408     mapAndUnzipRn rn_rbind rbinds       `thenRn` \ (rbinds', fvRbind_s) ->
 409     returnRn (rbinds', unionManyNameSets fvRbind_s)
 410   where
 411     (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
 412
 413     field_dup_err dups = addErrRn (dupFieldErr str dups)
 414
 415     rn_rbind (field, expr, pun)
 416       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 417         rnExpr expr             `thenRn` \ (expr', fvExpr) ->
 418         returnRn ((fieldname, expr', pun), fvExpr)
 419
 420 rnRpats rpats
 421   = mapRn field_dup_err dup_fields      `thenRn_`
 422     mapRn rn_rpat rpats
 423   where
 424     (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
 425
 426     field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
 427
 428     rn_rpat (field, pat, pun)
 429       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 430         rnPat pat               `thenRn` \ pat' ->
 431         returnRn (fieldname, pat', pun)
 432 \end{code}
 433
 434 %************************************************************************
 435 %*                                                                      *
 436 \subsubsection{@Stmt@s: in @do@ expressions}
 437 %*                                                                      *
 438 %************************************************************************
 439
 440 Note that although some bound vars may appear in the free var set for
 441 the first qual, these will eventually be removed by the caller. For
 442 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
 443 @[q <- r, p <- q]@, the free var set for @q <- r@ will
 444 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 445 @r@ will be removed only when we finally return from examining all the
 446 Quals.
 447
 448 \begin{code}
 449 type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 450
 451 rnStmts :: RnExprTy s
 452         -> [RdrNameStmt]
 453         -> RnMS s ([RenamedStmt], FreeVars)
 454
 455 rnStmts rn_expr []
 456   = returnRn ([], emptyNameSet)
 457
 458 rnStmts rn_expr (stmt:stmts)
 459   = rnStmt rn_expr stmt                         $ \ stmt' ->
 460     rnStmts rn_expr stmts                       `thenRn` \ (stmts', fvs) ->
 461     returnRn (stmt' : stmts', fvs)
 462
 463 rnStmt :: RnExprTy s -> RdrNameStmt
 464        -> (RenamedStmt -> RnMS s (a, FreeVars))
 465        -> RnMS s (a, FreeVars)
 466 -- Because of mutual recursion we have to pass in rnExpr.
 467
 468 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
 469   = pushSrcLocRn src_loc $
 470     rn_expr expr                                        `thenRn` \ (expr', fv_expr) ->
 471     bindLocalsRn "pattern in do binding" binders        $ \ new_binders ->
 472     rnPat pat                                           `thenRn` \ pat' ->
 473
 474     thing_inside (BindStmt pat' expr' src_loc)          `thenRn` \ (result, fvs) ->
 475     returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
 476   where
 477     binders = collectPatBinders pat
 478
 479 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
 480   = pushSrcLocRn src_loc $
 481     rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 482     thing_inside (ExprStmt expr' src_loc)       `thenRn` \ (result, fvs) ->
 483     returnRn (result, fv_expr `unionNameSets` fvs)
 484
 485 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
 486   = pushSrcLocRn src_loc $
 487     rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 488     thing_inside (GuardStmt expr' src_loc)      `thenRn` \ (result, fvs) ->
 489     returnRn (result, fv_expr `unionNameSets` fvs)
 490
 491 rnStmt rn_expr (ReturnStmt expr) thing_inside
 492   = rn_expr expr                                `thenRn` \ (expr', fv_expr) ->
 493     thing_inside (ReturnStmt expr')             `thenRn` \ (result, fvs) ->
 494     returnRn (result, fv_expr `unionNameSets` fvs)
 495
 496 rnStmt rn_expr (LetStmt binds) thing_inside
 497   = rnBinds binds               $ \ binds' ->
 498     thing_inside (LetStmt binds')
 499 \end{code}
 500
 501 %************************************************************************
 502 %*                                                                      *
 503 \subsubsection{Precedence Parsing}
 504 %*                                                                      *
 505 %************************************************************************
 506
 507 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 508 are assumed to be already correctly arranged.  It needs the fixities
 509 recorded in the OpApp nodes, because fixity info applies to the things
 510 the programmer actually wrote, so you can't find it out from the Name.
 511
 512 Furthermore, the second argument is guaranteed not to be another
 513 operator application.  Why? Because the parser parses all
 514 operator appications left-associatively.
 515
 516 \begin{code}
 517 mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
 518           -> RnMS s RenamedHsExpr
 519
 520 mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
 521           op2 fix2 e2
 522   | nofix_error
 523   = addErrRn (precParseErr (get op1,fix1) (get op2,fix2))       `thenRn_`
 524     returnRn (OpApp e1 op2 fix2 e2)
 525
 526   | rearrange_me
 527   = mkOpAppRn e12 op2 fix2 e2           `thenRn` \ new_e ->
 528     returnRn (OpApp e11 op1 fix1 new_e)
 529   where
 530     (nofix_error, rearrange_me) = compareFixity fix1 fix2
 531
 532 mkOpAppRn e1@(NegApp neg_arg neg_op)
 533           op2
 534           fix2@(Fixity prec2 dir2)
 535           e2
 536   | nofix_error
 537   = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
 538     returnRn (OpApp e1 op2 fix2 e2)
 539
 540   | rearrange_me
 541   = mkOpAppRn neg_arg op2 fix2 e2       `thenRn` \ new_e ->
 542     returnRn (NegApp new_e neg_op)
 543   where
 544     fix_neg = Fixity 6 InfixL   -- Precedence of unary negate is wired in as infixl 6!
 545     (nofix_error, rearrange_me) = compareFixity fix_neg fix2
 546
 547 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 548   = ASSERT( if right_op_ok fix e2 then True
 549             else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op, text "---", ppr fix, text "---", ppr e2])
 550     )
 551     returnRn (OpApp e1 op fix e2)
 552
 553 get (HsVar n) = n
 554
 555 -- Parser left-associates everything, but
 556 -- derived instances may have correctly-associated things to
 557 -- in the right operarand.  So we just check that the right operand is OK
 558 right_op_ok fix1 (OpApp _ _ fix2 _)
 559   = not error_please && associate_right
 560   where
 561     (error_please, associate_right) = compareFixity fix1 fix2
 562 right_op_ok fix1 other
 563   = True
 564
 565 -- Parser initially makes negation bind more tightly than any other operator
 566 mkNegAppRn neg_arg neg_op
 567   =
 568 #ifdef DEBUG
 569     getModeRn                   `thenRn` \ mode ->
 570     ASSERT( not_op_app mode neg_arg )
 571 #endif
 572     returnRn (NegApp neg_arg neg_op)
 573
 574 not_op_app SourceMode (OpApp _ _ _ _) = False
 575 not_op_app mode other                 = True
 576 \end{code}
 577
 578 \begin{code}
 579 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
 580              -> RnMS s RenamedPat
 581
 582 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
 583              op2 fix2 p2
 584   | nofix_error
 585   = addErrRn (precParseErr (op1,fix1) (op2,fix2))       `thenRn_`
 586     returnRn (ConOpPatIn p1 op2 fix2 p2)
 587
 588   | rearrange_me
 589   = mkConOpPatRn p12 op2 fix2 p2                `thenRn` \ new_p ->
 590     returnRn (ConOpPatIn p11 op1 fix1 new_p)
 591
 592   where
 593     (nofix_error, rearrange_me) = compareFixity fix1 fix2
 594
 595 mkConOpPatRn p1@(NegPatIn neg_arg)
 596           op2
 597           fix2@(Fixity prec2 dir2)
 598           p2
 599   | prec2 > 6   -- Precedence of unary - is wired in as 6!
 600   = addErrRn (precParseNegPatErr (op2,fix2))    `thenRn_`
 601     returnRn (ConOpPatIn p1 op2 fix2 p2)
 602
 603 mkConOpPatRn p1 op fix p2                       -- Default case, no rearrangment
 604   = ASSERT( not_op_pat p2 )
 605     returnRn (ConOpPatIn p1 op fix p2)
 606
 607 not_op_pat (ConOpPatIn _ _ _ _) = False
 608 not_op_pat other                = True
 609 \end{code}
 610
 611 \begin{code}
 612 checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
 613
 614 checkPrecMatch False fn match
 615   = returnRn ()
 616 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
 617   = checkPrec op p1 False       `thenRn_`
 618     checkPrec op p2 True
 619 checkPrecMatch True op _
 620   = panic "checkPrecMatch"
 621
 622 checkPrec op (ConOpPatIn _ op1 _ _) right
 623   = lookupFixity op     `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
 624     lookupFixity op1    `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
 625     let
 626         inf_ok = op1_prec > op_prec ||
 627                  (op1_prec == op_prec &&
 628                   (op1_dir == InfixR && op_dir == InfixR && right ||
 629                    op1_dir == InfixL && op_dir == InfixL && not right))
 630
 631         info  = (op,op_fix)
 632         info1 = (op1,op1_fix)
 633         (infol, infor) = if right then (info, info1) else (info1, info)
 634     in
 635     checkRn inf_ok (precParseErr infol infor)
 636
 637 checkPrec op (NegPatIn _) right
 638   = lookupFixity op     `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
 639     checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
 640
 641 checkPrec op pat right
 642   = returnRn ()
 643 \end{code}
 644
 645 Consider
 646         a `op1` b `op2` c
 647
 648 (compareFixity op1 op2) tells which way to arrange appication, or
 649 whether there's an error.
 650
 651 \begin{code}
 652 compareFixity :: Fixity -> Fixity
 653               -> (Bool,         -- Error please
 654                   Bool)         -- Associate to the right: a op1 (b op2 c)
 655 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
 656   = case prec1 `compare` prec2 of
 657         GT -> left
 658         LT -> right
 659         EQ -> case (dir1, dir2) of
 660                         (InfixR, InfixR) -> right
 661                         (InfixL, InfixL) -> left
 662                         _                -> error_please
 663   where
 664     right        = (False, True)
 665     left         = (False, False)
 666     error_please = (True,  False)
 667 \end{code}
 668
 669 %************************************************************************
 670 %*                                                                      *
 671 \subsubsection{Literals}
 672 %*                                                                      *
 673 %************************************************************************
 674
 675 When literals occur we have to make sure that the types and classes they involve
 676 are made available.
 677
 678 \begin{code}
 679 litOccurrence (HsChar _)
 680   = addImplicitOccRn charTyCon_name
 681
 682 litOccurrence (HsCharPrim _)
 683   = addImplicitOccRn (getName charPrimTyCon)
 684
 685 litOccurrence (HsString _)
 686   = addImplicitOccRn listTyCon_name     `thenRn_`
 687     addImplicitOccRn charTyCon_name
 688
 689 litOccurrence (HsStringPrim _)
 690   = addImplicitOccRn (getName addrPrimTyCon)
 691
 692 litOccurrence (HsInt _)
 693   = lookupImplicitOccRn numClass_RDR                    -- Int and Integer are forced in by Num
 694
 695 litOccurrence (HsFrac _)
 696   = lookupImplicitOccRn fractionalClass_RDR     `thenRn_`
 697     lookupImplicitOccRn ratioDataCon_RDR
 698         -- We have to make sure that the Ratio type is imported with
 699         -- its constructor, because literals of type Ratio t are
 700         -- built with that constructor.
 701         -- The Rational type is needed too, but that will come in
 702         -- when fractionalClass does.
 703
 704 litOccurrence (HsIntPrim _)
 705   = addImplicitOccRn (getName intPrimTyCon)
 706
 707 litOccurrence (HsFloatPrim _)
 708   = addImplicitOccRn (getName floatPrimTyCon)
 709
 710 litOccurrence (HsDoublePrim _)
 711   = addImplicitOccRn (getName doublePrimTyCon)
 712
 713 litOccurrence (HsLitLit _)
 714   = lookupImplicitOccRn ccallableClass_RDR
 715 \end{code}
 716
 717 %************************************************************************
 718 %*                                                                      *
 719 \subsubsection{Assertion utils}
 720 %*                                                                      *
 721 %************************************************************************
 722
 723 \begin{code}
 724 mkAssertExpr :: RnMS s RenamedHsExpr
 725 mkAssertExpr =
 726   newImportedGlobalName mod occ HiFile `thenRn` \ name ->
 727   addOccurrenceName name               `thenRn_`
 728   getSrcLocRn                          `thenRn` \ sloc ->
 729   let
 730    expr = HsApp (HsVar name)
 731                 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
 732   in
 733   returnRn expr
 734
 735   where
 736    mod = rdrNameModule assertErr_RDR
 737    occ = rdrNameOcc assertErr_RDR
 738 \end{code}
 739
 740 %************************************************************************
 741 %*                                                                      *
 742 \subsubsection{Errors}
 743 %*                                                                      *
 744 %************************************************************************
 745
 746 \begin{code}
 747 dupFieldErr str (dup:rest)
 748   = hsep [ptext SLIT("duplicate field name"),
 749           quotes (ppr dup),
 750           ptext SLIT("in record"), text str]
 751
 752 negPatErr pat
 753   = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)]
 754
 755 precParseNegPatErr op
 756   = hang (ptext SLIT("precedence parsing error"))
 757       4 (hsep [ptext SLIT("prefix `-' has lower precedence than"),
 758                quotes (pp_op op),
 759                ptext SLIT("in pattern")])
 760
 761 precParseErr op1 op2
 762   = hang (ptext SLIT("precedence parsing error"))
 763       4 (hsep [ptext SLIT("cannot mix"), quotes (pp_op op1), ptext SLIT("and"),
 764                quotes (pp_op op2),
 765                ptext SLIT("in the same infix expression")])
 766
 767 nonStdGuardErr guard
 768   = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
 769       4 (ppr guard)
 770
 771 pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]
 772 \end{code}