ghc/compiler/rename/RnExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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
  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(..) )
  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,
  34                           ioDataCon_RDR, ioOkDataCon_RDR
  35                         )
  36 import TysPrim          ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
  37                           floatPrimTyCon, doublePrimTyCon
  38                         )
  39 import Name
  40 import UniqFM           ( lookupUFM, {- ToDo:rm-} isNullUFM )
  41 import UniqSet          ( emptyUniqSet, unitUniqSet,
  42                           unionUniqSets, unionManyUniqSets,
  43                           UniqSet
  44                         )
  45 import Util             ( removeDups )
  46 import Outputable
  47 \end{code}
  48
  49
  50 *********************************************************
  51 *                                                       *
  52 \subsection{Patterns}
  53 *                                                       *
  54 *********************************************************
  55
  56 \begin{code}
  57 rnPat :: RdrNamePat -> RnMS s RenamedPat
  58
  59 rnPat WildPatIn = returnRn WildPatIn
  60
  61 rnPat (VarPatIn name)
  62   = lookupBndrRn  name                  `thenRn` \ vname ->
  63     returnRn (VarPatIn vname)
  64
  65 rnPat (LitPatIn lit)
  66   = litOccurrence lit                   `thenRn_`
  67     lookupImplicitOccRn eqClass_RDR     `thenRn_`       -- Needed to find equality on pattern
  68     returnRn (LitPatIn lit)
  69
  70 rnPat (LazyPatIn pat)
  71   = rnPat pat           `thenRn` \ pat' ->
  72     returnRn (LazyPatIn pat')
  73
  74 rnPat (AsPatIn name pat)
  75   = rnPat pat           `thenRn` \ pat' ->
  76     lookupBndrRn name   `thenRn` \ vname ->
  77     returnRn (AsPatIn vname pat')
  78
  79 rnPat (ConPatIn con pats)
  80   = lookupOccRn con     `thenRn` \ con' ->
  81     mapRn rnPat pats    `thenRn` \ patslist ->
  82     returnRn (ConPatIn con' patslist)
  83
  84 rnPat (ConOpPatIn pat1 con _ pat2)
  85   = rnPat pat1          `thenRn` \ pat1' ->
  86     lookupOccRn con     `thenRn` \ con' ->
  87     lookupFixity con    `thenRn` \ fixity ->
  88     rnPat pat2          `thenRn` \ pat2' ->
  89     mkConOpPatRn pat1' con' fixity pat2'
  90
  91 -- Negated patters can only be literals, and they are dealt with
  92 -- by negating the literal at compile time, not by using the negation
  93 -- operation in Num.  So we don't need to make an implicit reference
  94 -- to negate_RDR.
  95 rnPat neg@(NegPatIn pat)
  96   = checkRn (valid_neg_pat pat) (negPatErr neg)
  97                         `thenRn_`
  98     rnPat pat           `thenRn` \ pat' ->
  99     returnRn (NegPatIn pat')
 100   where
 101     valid_neg_pat (LitPatIn (HsInt  _)) = True
 102     valid_neg_pat (LitPatIn (HsFrac _)) = True
 103     valid_neg_pat _                     = False
 104
 105 rnPat (ParPatIn pat)
 106   = rnPat pat           `thenRn` \ pat' ->
 107     returnRn (ParPatIn pat')
 108
 109 rnPat (NPlusKPatIn name lit)
 110   = litOccurrence lit                   `thenRn_`
 111     lookupImplicitOccRn ordClass_RDR    `thenRn_`
 112     lookupBndrRn name                   `thenRn` \ name' ->
 113     returnRn (NPlusKPatIn name' lit)
 114
 115 rnPat (ListPatIn pats)
 116   = addImplicitOccRn listType_name      `thenRn_`
 117     mapRn rnPat pats                    `thenRn` \ patslist ->
 118     returnRn (ListPatIn patslist)
 119
 120 rnPat (TuplePatIn pats)
 121   = addImplicitOccRn (tupleType_name (length pats))     `thenRn_`
 122     mapRn rnPat pats                                    `thenRn` \ patslist ->
 123     returnRn (TuplePatIn patslist)
 124
 125 rnPat (RecPatIn con rpats)
 126   = lookupOccRn con     `thenRn` \ con' ->
 127     rnRpats rpats       `thenRn` \ rpats' ->
 128     returnRn (RecPatIn con' rpats')
 129 \end{code}
 130
 131 ************************************************************************
 132 *                                                                       *
 133 \subsection{Match}
 134 *                                                                       *
 135 ************************************************************************
 136
 137 \begin{code}
 138 rnMatch, rnMatch1 :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
 139
 140 -- The only tricky bit here is that we want to do a single
 141 -- bindLocalsRn for all the matches together, so that we spot
 142 -- the repeated variable in
 143 --      f x x = 1
 144
 145 rnMatch match
 146   = pushSrcLocRn (getMatchLoc match) $
 147     bindLocalsRn "pattern" (get_binders match)  $ \ new_binders ->
 148     rnMatch1 match                              `thenRn` \ (match', fvs) ->
 149     let
 150         binder_set     = mkNameSet new_binders
 151         unused_binders = binder_set `minusNameSet` fvs
 152         net_fvs        = fvs `minusNameSet` binder_set
 153     in
 154     warnUnusedMatches unused_binders            `thenRn_`
 155
 156     returnRn (match', net_fvs)
 157  where
 158     get_binders (GRHSMatch _)        = []
 159     get_binders (PatMatch pat match) = collectPatBinders pat ++ get_binders match
 160
 161 rnMatch1 (PatMatch pat match)
 162   = rnPat pat                           `thenRn` \ pat' ->
 163     rnMatch1 match                      `thenRn` \ (match', fvs) ->
 164     returnRn (PatMatch pat' match', fvs)
 165
 166 rnMatch1 (GRHSMatch grhss_and_binds)
 167   = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
 168     returnRn (GRHSMatch grhss_and_binds', fvs)
 169 \end{code}
 170
 171 %************************************************************************
 172 %*                                                                      *
 173 \subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
 174 %*                                                                      *
 175 %************************************************************************
 176
 177 \begin{code}
 178 rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
 179
 180 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
 181   = rnBinds binds               $ \ binds' ->
 182     rnGRHSs grhss               `thenRn` \ (grhss', fvGRHS) ->
 183     returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS)
 184   where
 185     rnGRHSs [] = returnRn ([], emptyNameSet)
 186
 187     rnGRHSs (grhs:grhss)
 188       = rnGRHS  grhs   `thenRn` \ (grhs',  fvs) ->
 189         rnGRHSs grhss  `thenRn` \ (grhss', fvss) ->
 190         returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
 191
 192     rnGRHS (GRHS guard expr locn)
 193       = pushSrcLocRn locn $
 194         (if not (opt_GlasgowExts || is_standard_guard guard) then
 195                 addWarnRn (nonStdGuardErr guard)
 196          else
 197                 returnRn ()
 198         )               `thenRn_`
 199
 200         (rnStmts rnExpr guard   $ \ guard' ->
 201                 -- This nested thing deals with scope and
 202                 -- the free vars of the guard, and knocking off the
 203                 -- free vars of the rhs that are bound by the guard
 204
 205         rnExpr expr     `thenRn` \ (expr',  fvse) ->
 206         returnRn (GRHS guard' expr' locn, fvse))
 207
 208         -- Standard Haskell 1.4 guards are just a single boolean
 209         -- expression, rather than a list of qualifiers as in the
 210         -- Glasgow extension
 211     is_standard_guard []              = True
 212     is_standard_guard [GuardStmt _ _] = True
 213     is_standard_guard other           = False
 214 \end{code}
 215
 216 %************************************************************************
 217 %*                                                                      *
 218 \subsubsection{Expressions}
 219 %*                                                                      *
 220 %************************************************************************
 221
 222 \begin{code}
 223 rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
 224 rnExprs ls = rnExprs' ls emptyUniqSet
 225  where
 226   rnExprs' [] acc = returnRn ([], acc)
 227   rnExprs' (expr:exprs) acc
 228    = rnExpr expr                `thenRn` \ (expr', fvExpr) ->
 229
 230         -- Now we do a "seq" on the free vars because typically it's small
 231         -- or empty, especially in very long lists of constants
 232     let
 233         acc' = acc `unionNameSets` fvExpr
 234     in
 235     (grubby_seqNameSet acc' rnExprs') exprs acc'        `thenRn` \ (exprs', fvExprs) ->
 236     returnRn (expr':exprs', fvExprs)
 237
 238 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
 239 grubby_seqNameSet ns result | isNullUFM ns = result
 240                             | otherwise    = result
 241 \end{code}
 242
 243 Variables. We look up the variable and return the resulting name.  The
 244 interesting question is what the free-variable set should be.  We
 245 don't want to return imported or prelude things as free vars.  So we
 246 look at the Name returned from the lookup, and make it part of the
 247 free-var set iff if it's a LocallyDefined Name.
 248 \end{itemize}
 249
 250 \begin{code}
 251 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 252
 253 rnExpr (HsVar v)
 254   = lookupOccRn v       `thenRn` \ vname ->
 255     returnRn (HsVar vname, if isLocallyDefined vname
 256                            then unitNameSet vname
 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     lookupImplicitOccRn ioOkDataCon_RDR         `thenRn_`
 317     rnExprs args                                `thenRn` \ (args', fvs_args) ->
 318     returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
 319
 320 rnExpr (HsSCC label expr)
 321   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 322     returnRn (HsSCC label expr', fvs_expr)
 323
 324 rnExpr (HsCase expr ms src_loc)
 325   = pushSrcLocRn src_loc $
 326     rnExpr expr                 `thenRn` \ (new_expr, e_fvs) ->
 327     mapAndUnzipRn rnMatch ms    `thenRn` \ (new_ms, ms_fvs) ->
 328     returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
 329
 330 rnExpr (HsLet binds expr)
 331   = rnBinds binds               $ \ binds' ->
 332     rnExpr expr                  `thenRn` \ (expr',fvExpr) ->
 333     returnRn (HsLet binds' expr', fvExpr)
 334
 335 rnExpr (HsDo do_or_lc stmts src_loc)
 336   = pushSrcLocRn src_loc $
 337     lookupImplicitOccRn monadZeroClass_RDR      `thenRn_`       -- Forces Monad to come too
 338     (rnStmts rnExpr stmts                       $ \ stmts' ->
 339     returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet))
 340
 341 rnExpr (ExplicitList exps)
 342   = addImplicitOccRn listType_name      `thenRn_`
 343     rnExprs exps                        `thenRn` \ (exps', fvs) ->
 344     returnRn  (ExplicitList exps', fvs)
 345
 346 rnExpr (ExplicitTuple exps)
 347   = addImplicitOccRn (tupleType_name (length exps))     `thenRn_`
 348     rnExprs exps                                        `thenRn` \ (exps', fvExps) ->
 349     returnRn (ExplicitTuple exps', fvExps)
 350
 351 rnExpr (RecordCon con_id _ rbinds)
 352   = lookupOccRn con_id                  `thenRn` \ conname ->
 353     rnRbinds "construction" rbinds      `thenRn` \ (rbinds', fvRbinds) ->
 354     returnRn (RecordCon conname (error "rnExpr:RecordCon") rbinds', fvRbinds)
 355
 356 rnExpr (RecordUpd expr rbinds)
 357   = rnExpr expr                 `thenRn` \ (expr', fvExpr) ->
 358     rnRbinds "update" rbinds    `thenRn` \ (rbinds', fvRbinds) ->
 359     returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
 360
 361 rnExpr (ExprWithTySig expr pty)
 362   = rnExpr expr                                 `thenRn` \ (expr', fvExpr) ->
 363     rnHsSigType (text "an expression") pty      `thenRn` \ pty' ->
 364     returnRn (ExprWithTySig expr' pty', fvExpr)
 365
 366 rnExpr (HsIf p b1 b2 src_loc)
 367   = pushSrcLocRn src_loc $
 368     rnExpr p            `thenRn` \ (p', fvP) ->
 369     rnExpr b1           `thenRn` \ (b1', fvB1) ->
 370     rnExpr b2           `thenRn` \ (b2', fvB2) ->
 371     returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
 372
 373 rnExpr (ArithSeqIn seq)
 374   = lookupImplicitOccRn enumClass_RDR   `thenRn_`
 375     rn_seq seq                          `thenRn` \ (new_seq, fvs) ->
 376     returnRn (ArithSeqIn new_seq, fvs)
 377   where
 378     rn_seq (From expr)
 379      = rnExpr expr      `thenRn` \ (expr', fvExpr) ->
 380        returnRn (From expr', fvExpr)
 381
 382     rn_seq (FromThen expr1 expr2)
 383      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 384        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 385        returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 386
 387     rn_seq (FromTo expr1 expr2)
 388      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 389        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 390        returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 391
 392     rn_seq (FromThenTo expr1 expr2 expr3)
 393      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 394        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 395        rnExpr expr3     `thenRn` \ (expr3', fvExpr3) ->
 396        returnRn (FromThenTo expr1' expr2' expr3',
 397                   unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
 398 \end{code}
 399
 400 %************************************************************************
 401 %*                                                                      *
 402 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 403 %*                                                                      *
 404 %************************************************************************
 405
 406 \begin{code}
 407 rnRbinds str rbinds
 408   = mapRn field_dup_err dup_fields      `thenRn_`
 409     mapAndUnzipRn rn_rbind rbinds       `thenRn` \ (rbinds', fvRbind_s) ->
 410     returnRn (rbinds', unionManyNameSets fvRbind_s)
 411   where
 412     (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
 413
 414     field_dup_err dups = addErrRn (dupFieldErr str dups)
 415
 416     rn_rbind (field, expr, pun)
 417       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 418         rnExpr expr             `thenRn` \ (expr', fvExpr) ->
 419         returnRn ((fieldname, expr', pun), fvExpr)
 420
 421 rnRpats rpats
 422   = mapRn field_dup_err dup_fields      `thenRn_`
 423     mapRn rn_rpat rpats
 424   where
 425     (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
 426
 427     field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
 428
 429     rn_rpat (field, pat, pun)
 430       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 431         rnPat pat               `thenRn` \ pat' ->
 432         returnRn (fieldname, pat', pun)
 433 \end{code}
 434
 435 %************************************************************************
 436 %*                                                                      *
 437 \subsubsection{@Stmt@s: in @do@ expressions}
 438 %*                                                                      *
 439 %************************************************************************
 440
 441 Note that although some bound vars may appear in the free var set for
 442 the first qual, these will eventually be removed by the caller. For
 443 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
 444 @[q <- r, p <- q]@, the free var set for @q <- r@ will
 445 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 446 @r@ will be removed only when we finally return from examining all the
 447 Quals.
 448
 449 \begin{code}
 450 type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 451
 452 rnStmts :: RnExprTy s
 453         -> [RdrNameStmt]
 454         -> ([RenamedStmt] -> RnMS s (a, FreeVars))
 455         -> RnMS s (a, FreeVars)
 456
 457 rnStmts rn_expr [] thing_inside
 458   = thing_inside []
 459
 460 rnStmts rn_expr (stmt:stmts) thing_inside
 461   = rnStmt rn_expr stmt                         $ \ stmt' ->
 462     rnStmts rn_expr stmts                       $ \ stmts' ->
 463     thing_inside (stmt' : stmts')
 464
 465 rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> 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 charType_name
 681
 682 litOccurrence (HsCharPrim _)
 683   = addImplicitOccRn (getName charPrimTyCon)
 684
 685 litOccurrence (HsString _)
 686   = addImplicitOccRn listType_name      `thenRn_`
 687     addImplicitOccRn charType_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 %*                                                                      *
 720 \subsubsection{Errors}
 721 %*                                                                      *
 722 %************************************************************************
 723
 724 \begin{code}
 725 dupFieldErr str (dup:rest)
 726   = hsep [ptext SLIT("duplicate field name"),
 727           quotes (ppr dup),
 728           ptext SLIT("in record"), text str]
 729
 730 negPatErr pat
 731   = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)]
 732
 733 precParseNegPatErr op
 734   = hang (ptext SLIT("precedence parsing error"))
 735       4 (hsep [ptext SLIT("prefix `-' has lower precedence than"),
 736                quotes (pp_op op),
 737                ptext SLIT("in pattern")])
 738
 739 precParseErr op1 op2
 740   = hang (ptext SLIT("precedence parsing error"))
 741       4 (hsep [ptext SLIT("cannot mix"), quotes (pp_op op1), ptext SLIT("and"),
 742                quotes (pp_op op2),
 743                ptext SLIT("in the same infix expression")])
 744
 745 nonStdGuardErr guard
 746   = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
 747       4 (ppr guard)
 748
 749 pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]
 750 \end{code}