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