ghc/compiler/rename/RnExpr.lhs

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