compiler/rename/RnTypes.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnSource]{Main pass of renamer}
   5
   6 \begin{code}
   7 module RnTypes (
   8         -- Type related stuff
   9         rnHsType, rnLHsType, rnLHsTypes, rnContext,
  10         rnHsSigType, rnHsTypeFVs,
  11
  12         -- Patterns and literals
  13         rnLPat, rnPat, rnPatsAndThen,   -- Here because it's not part
  14         rnLit, rnOverLit,               -- of any mutual recursion
  15
  16         -- Precence related stuff
  17         mkOpAppRn, mkNegAppRn, mkOpFormRn,
  18         checkPrecMatch, checkSectionPrec,
  19
  20         -- Error messages
  21         dupFieldErr, patSigErr, checkTupSize
  22   ) where
  23
  24 import DynFlags         ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) )
  25
  26 import HsSyn
  27 import RdrHsSyn         ( extractHsRhoRdrTyVars )
  28 import RnHsSyn          ( extractHsTyNames, parrTyCon_name, tupleTyCon_name,
  29                           listTyCon_name
  30                         )
  31 import RnEnv            ( lookupOccRn, lookupBndrRn, lookupSyntaxName,
  32                           lookupLocatedOccRn, lookupLocatedBndrRn,
  33                           lookupLocatedGlobalOccRn, bindTyVarsRn,
  34                           lookupFixityRn, lookupTyFixityRn,
  35                           mapFvRn, warnUnusedMatches,
  36                           newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV )
  37 import TcRnMonad
  38 import RdrName          ( RdrName, elemLocalRdrEnv )
  39 import PrelNames        ( eqClassName, integralClassName, geName, eqName,
  40                           negateName, minusName, lengthPName, indexPName,
  41                           plusIntegerName, fromIntegerName, timesIntegerName,
  42                           ratioDataConName, fromRationalName )
  43 import TypeRep          ( funTyCon )
  44 import Constants        ( mAX_TUPLE_SIZE )
  45 import Name             ( Name )
  46 import SrcLoc           ( SrcSpan, Located(..), unLoc, noLoc, combineLocs )
  47 import NameSet
  48
  49 import Literal          ( inIntRange, inCharRange )
  50 import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
  51                           Fixity(..), FixityDirection(..) )
  52 import ListSetOps       ( removeDups )
  53 import Outputable
  54
  55 #include "HsVersions.h"
  56 \end{code}
  57
  58 These type renamers are in a separate module, rather than in (say) RnSource,
  59 to break several loop.
  60
  61 %*********************************************************
  62 %*                                                      *
  63 \subsection{Renaming types}
  64 %*                                                      *
  65 %*********************************************************
  66
  67 \begin{code}
  68 rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
  69 rnHsTypeFVs doc_str ty
  70   = rnLHsType doc_str ty        `thenM` \ ty' ->
  71     returnM (ty', extractHsTyNames ty')
  72
  73 rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
  74         -- rnHsSigType is used for source-language type signatures,
  75         -- which use *implicit* universal quantification.
  76 rnHsSigType doc_str ty
  77   = rnLHsType (text "In the type signature for" <+> doc_str) ty
  78 \end{code}
  79
  80 rnHsType is here because we call it from loadInstDecl, and I didn't
  81 want a gratuitous knot.
  82
  83 \begin{code}
  84 rnLHsType  :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
  85 rnLHsType doc = wrapLocM (rnHsType doc)
  86
  87 rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)
  88
  89 rnHsType doc (HsForAllTy Implicit _ ctxt ty)
  90         -- Implicit quantifiction in source code (no kinds on tyvars)
  91         -- Given the signature  C => T  we universally quantify
  92         -- over FV(T) \ {in-scope-tyvars}
  93   = getLocalRdrEnv              `thenM` \ name_env ->
  94     let
  95         mentioned = extractHsRhoRdrTyVars ctxt ty
  96
  97         -- Don't quantify over type variables that are in scope;
  98         -- when GlasgowExts is off, there usually won't be any, except for
  99         -- class signatures:
 100         --      class C a where { op :: a -> a }
 101         forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
 102         tyvar_bndrs   = userHsTyVarBndrs forall_tyvars
 103     in
 104     rnForAll doc Implicit tyvar_bndrs ctxt ty
 105
 106 rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau)
 107         -- Explicit quantification.
 108         -- Check that the forall'd tyvars are actually
 109         -- mentioned in the type, and produce a warning if not
 110   = let
 111         mentioned          = map unLoc (extractHsRhoRdrTyVars ctxt tau)
 112         forall_tyvar_names = hsLTyVarLocNames forall_tyvars
 113
 114         -- Explicitly quantified but not mentioned in ctxt or tau
 115         warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names
 116     in
 117     mappM_ (forAllWarn doc tau) warn_guys       `thenM_`
 118     rnForAll doc Explicit forall_tyvars ctxt tau
 119
 120 rnHsType doc (HsTyVar tyvar)
 121   = lookupOccRn tyvar           `thenM` \ tyvar' ->
 122     returnM (HsTyVar tyvar')
 123
 124 rnHsType doc (HsOpTy ty1 (L loc op) ty2)
 125   = setSrcSpan loc (
 126       lookupOccRn op                    `thenM` \ op' ->
 127       let
 128         l_op' = L loc op'
 129       in
 130       lookupTyFixityRn l_op'            `thenM` \ fix ->
 131       rnLHsType doc ty1                 `thenM` \ ty1' ->
 132       rnLHsType doc ty2                 `thenM` \ ty2' ->
 133       mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2'
 134    )
 135
 136 rnHsType doc (HsParTy ty)
 137   = rnLHsType doc ty            `thenM` \ ty' ->
 138     returnM (HsParTy ty')
 139
 140 rnHsType doc (HsBangTy b ty)
 141   = rnLHsType doc ty            `thenM` \ ty' ->
 142     returnM (HsBangTy b ty')
 143
 144 rnHsType doc (HsNumTy i)
 145   | i == 1    = returnM (HsNumTy i)
 146   | otherwise = addErr err_msg  `thenM_`  returnM (HsNumTy i)
 147   where
 148     err_msg = ptext SLIT("Only unit numeric type pattern is valid")
 149
 150
 151 rnHsType doc (HsFunTy ty1 ty2)
 152   = rnLHsType doc ty1   `thenM` \ ty1' ->
 153         -- Might find a for-all as the arg of a function type
 154     rnLHsType doc ty2   `thenM` \ ty2' ->
 155         -- Or as the result.  This happens when reading Prelude.hi
 156         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 157
 158         -- Check for fixity rearrangements
 159     mkHsOpTyRn HsFunTy (ppr funTyCon) funTyFixity ty1' ty2'
 160
 161 rnHsType doc (HsListTy ty)
 162   = rnLHsType doc ty                            `thenM` \ ty' ->
 163     returnM (HsListTy ty')
 164
 165 rnHsType doc (HsKindSig ty k)
 166   = rnLHsType doc ty                            `thenM` \ ty' ->
 167     returnM (HsKindSig ty' k)
 168
 169 rnHsType doc (HsPArrTy ty)
 170   = rnLHsType doc ty                            `thenM` \ ty' ->
 171     returnM (HsPArrTy ty')
 172
 173 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 174 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 175 rnHsType doc (HsTupleTy tup_con tys)
 176   = mappM (rnLHsType doc) tys           `thenM` \ tys' ->
 177     returnM (HsTupleTy tup_con tys')
 178
 179 rnHsType doc (HsAppTy ty1 ty2)
 180   = rnLHsType doc ty1           `thenM` \ ty1' ->
 181     rnLHsType doc ty2           `thenM` \ ty2' ->
 182     returnM (HsAppTy ty1' ty2')
 183
 184 rnHsType doc (HsPredTy pred)
 185   = rnPred doc pred     `thenM` \ pred' ->
 186     returnM (HsPredTy pred')
 187
 188 rnHsType doc (HsSpliceTy _)
 189   = do  { addErr (ptext SLIT("Type splices are not yet implemented"))
 190         ; failM }
 191
 192 rnLHsTypes doc tys = mappM (rnLHsType doc) tys
 193 \end{code}
 194
 195
 196 \begin{code}
 197 rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
 198          -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
 199
 200 rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty
 201         -- One reason for this case is that a type like Int#
 202         -- starts off as (HsForAllTy Nothing [] Int), in case
 203         -- there is some quantification.  Now that we have quantified
 204         -- and discovered there are no type variables, it's nicer to turn
 205         -- it into plain Int.  If it were Int# instead of Int, we'd actually
 206         -- get an error, because the body of a genuine for-all is
 207         -- of kind *.
 208
 209 rnForAll doc exp forall_tyvars ctxt ty
 210   = bindTyVarsRn doc forall_tyvars      $ \ new_tyvars ->
 211     rnContext doc ctxt                  `thenM` \ new_ctxt ->
 212     rnLHsType doc ty                    `thenM` \ new_ty ->
 213     returnM (HsForAllTy exp new_tyvars new_ctxt new_ty)
 214         -- Retain the same implicit/explicit flag as before
 215         -- so that we can later print it correctly
 216 \end{code}
 217
 218
 219 %************************************************************************
 220 %*                                                                      *
 221         Fixities and precedence parsing
 222 %*                                                                      *
 223 %************************************************************************
 224
 225 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 226 are assumed to be already correctly arranged.  It needs the fixities
 227 recorded in the OpApp nodes, because fixity info applies to the things
 228 the programmer actually wrote, so you can't find it out from the Name.
 229
 230 Furthermore, the second argument is guaranteed not to be another
 231 operator application.  Why? Because the parser parses all
 232 operator appications left-associatively, EXCEPT negation, which
 233 we need to handle specially.
 234 Infix types are read in a *right-associative* way, so that
 235         a `op` b `op` c
 236 is always read in as
 237         a `op` (b `op` c)
 238
 239 mkHsOpTyRn rearranges where necessary.  The two arguments
 240 have already been renamed and rearranged.  It's made rather tiresome
 241 by the presence of ->, which is a separate syntactic construct.
 242
 243 \begin{code}
 244 ---------------
 245 -- Building (ty1 `op1` (ty21 `op2` ty22))
 246 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
 247            -> SDoc -> Fixity -> LHsType Name -> LHsType Name
 248            -> RnM (HsType Name)
 249
 250 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
 251   = do  { fix2 <- lookupTyFixityRn op2
 252         ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
 253                       (\t1 t2 -> HsOpTy t1 op2 t2)
 254                       (ppr op2) fix2 ty21 ty22 loc2 }
 255
 256 mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2@(L loc2 (HsFunTy ty21 ty22))
 257   = mk_hs_op_ty mk1 pp_op1 fix1 ty1
 258                 HsFunTy (ppr funTyCon) funTyFixity ty21 ty22 loc2
 259
 260 mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2              -- Default case, no rearrangment
 261   = return (mk1 ty1 ty2)
 262
 263 ---------------
 264 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
 265             -> SDoc -> Fixity -> LHsType Name
 266             -> (LHsType Name -> LHsType Name -> HsType Name)
 267             -> SDoc -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
 268             -> RnM (HsType Name)
 269 mk_hs_op_ty mk1 pp_op1 fix1 ty1
 270             mk2 pp_op2 fix2 ty21 ty22 loc2
 271   | nofix_error     = do { addErr (precParseErr (quotes pp_op1,fix1)
 272                                                 (quotes pp_op2,fix2))
 273                          ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
 274   | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
 275   | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
 276                            new_ty <- mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty21
 277                          ; return (mk2 (noLoc new_ty) ty22) }
 278   where
 279     (nofix_error, associate_right) = compareFixity fix1 fix2
 280
 281
 282 ---------------------------
 283 mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged
 284           -> LHsExpr Name -> Fixity             -- Operator and fixity
 285           -> LHsExpr Name                       -- Right operand (not an OpApp, but might
 286                                                 -- be a NegApp)
 287           -> RnM (HsExpr Name)
 288
 289 -- (e11 `op1` e12) `op2` e2
 290 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
 291   | nofix_error
 292   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
 293     returnM (OpApp e1 op2 fix2 e2)
 294
 295   | associate_right
 296   = mkOpAppRn e12 op2 fix2 e2           `thenM` \ new_e ->
 297     returnM (OpApp e11 op1 fix1 (L loc' new_e))
 298   where
 299     loc'= combineLocs e12 e2
 300     (nofix_error, associate_right) = compareFixity fix1 fix2
 301
 302 ---------------------------
 303 --      (- neg_arg) `op` e2
 304 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
 305   | nofix_error
 306   = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))      `thenM_`
 307     returnM (OpApp e1 op2 fix2 e2)
 308
 309   | associate_right
 310   = mkOpAppRn neg_arg op2 fix2 e2       `thenM` \ new_e ->
 311     returnM (NegApp (L loc' new_e) neg_name)
 312   where
 313     loc' = combineLocs neg_arg e2
 314     (nofix_error, associate_right) = compareFixity negateFixity fix2
 315
 316 ---------------------------
 317 --      e1 `op` - neg_arg
 318 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _))       -- NegApp can occur on the right
 319   | not associate_right                         -- We *want* right association
 320   = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))    `thenM_`
 321     returnM (OpApp e1 op1 fix1 e2)
 322   where
 323     (_, associate_right) = compareFixity fix1 negateFixity
 324
 325 ---------------------------
 326 --      Default case
 327 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 328   = ASSERT2( right_op_ok fix (unLoc e2),
 329              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
 330     )
 331     returnM (OpApp e1 op fix e2)
 332
 333 -- Parser left-associates everything, but
 334 -- derived instances may have correctly-associated things to
 335 -- in the right operarand.  So we just check that the right operand is OK
 336 right_op_ok fix1 (OpApp _ _ fix2 _)
 337   = not error_please && associate_right
 338   where
 339     (error_please, associate_right) = compareFixity fix1 fix2
 340 right_op_ok fix1 other
 341   = True
 342
 343 -- Parser initially makes negation bind more tightly than any other operator
 344 -- And "deriving" code should respect this (use HsPar if not)
 345 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
 346 mkNegAppRn neg_arg neg_name
 347   = ASSERT( not_op_app (unLoc neg_arg) )
 348     returnM (NegApp neg_arg neg_name)
 349
 350 not_op_app (OpApp _ _ _ _) = False
 351 not_op_app other           = True
 352
 353 ---------------------------
 354 mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
 355           -> LHsExpr Name -> Fixity     -- Operator and fixity
 356           -> LHsCmdTop Name             -- Right operand (not an infix)
 357           -> RnM (HsCmd Name)
 358
 359 -- (e11 `op1` e12) `op2` e2
 360 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
 361         op2 fix2 a2
 362   | nofix_error
 363   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
 364     returnM (HsArrForm op2 (Just fix2) [a1, a2])
 365
 366   | associate_right
 367   = mkOpFormRn a12 op2 fix2 a2          `thenM` \ new_c ->
 368     returnM (HsArrForm op1 (Just fix1)
 369         [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
 370         -- TODO: locs are wrong
 371   where
 372     (nofix_error, associate_right) = compareFixity fix1 fix2
 373
 374 --      Default case
 375 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
 376   = returnM (HsArrForm op (Just fix) [arg1, arg2])
 377
 378
 379 --------------------------------------
 380 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
 381              -> RnM (Pat Name)
 382
 383 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
 384   = lookupFixityRn (unLoc op1)  `thenM` \ fix1 ->
 385     let
 386         (nofix_error, associate_right) = compareFixity fix1 fix2
 387     in
 388     if nofix_error then
 389         addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))       `thenM_`
 390         returnM (ConPatIn op2 (InfixCon p1 p2))
 391     else
 392     if associate_right then
 393         mkConOpPatRn op2 fix2 p12 p2            `thenM` \ new_p ->
 394         returnM (ConPatIn op1 (InfixCon p11 (L loc new_p)))  -- XXX loc right?
 395     else
 396     returnM (ConPatIn op2 (InfixCon p1 p2))
 397
 398 mkConOpPatRn op fix p1 p2                       -- Default case, no rearrangment
 399   = ASSERT( not_op_pat (unLoc p2) )
 400     returnM (ConPatIn op (InfixCon p1 p2))
 401
 402 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
 403 not_op_pat other                       = True
 404
 405 --------------------------------------
 406 checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
 407         -- True indicates an infix lhs
 408         -- See comments with rnExpr (OpApp ...) about "deriving"
 409
 410 checkPrecMatch False fn match
 411   = returnM ()
 412 checkPrecMatch True op (MatchGroup ms _)
 413   = mapM_ check ms
 414   where
 415     check (L _ (Match (p1:p2:_) _ _))
 416       = checkPrec op (unLoc p1) False   `thenM_`
 417         checkPrec op (unLoc p2) True
 418
 419     check _ = return ()
 420         -- This can happen.  Consider
 421         --      a `op` True = ...
 422         --      op          = ...
 423         -- The infix flag comes from the first binding of the group
 424         -- but the second eqn has no args (an error, but not discovered
 425         -- until the type checker).  So we don't want to crash on the
 426         -- second eqn.
 427
 428 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
 429   = lookupFixityRn op           `thenM` \  op_fix@(Fixity op_prec  op_dir) ->
 430     lookupFixityRn (unLoc op1)  `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
 431     let
 432         inf_ok = op1_prec > op_prec ||
 433                  (op1_prec == op_prec &&
 434                   (op1_dir == InfixR && op_dir == InfixR && right ||
 435                    op1_dir == InfixL && op_dir == InfixL && not right))
 436
 437         info  = (ppr_op op,  op_fix)
 438         info1 = (ppr_op op1, op1_fix)
 439         (infol, infor) = if right then (info, info1) else (info1, info)
 440     in
 441     checkErr inf_ok (precParseErr infol infor)
 442
 443 checkPrec op pat right
 444   = returnM ()
 445
 446 -- Check precedence of (arg op) or (op arg) respectively
 447 -- If arg is itself an operator application, then either
 448 --   (a) its precedence must be higher than that of op
 449 --   (b) its precedency & associativity must be the same as that of op
 450 checkSectionPrec :: FixityDirection -> HsExpr RdrName
 451         -> LHsExpr Name -> LHsExpr Name -> RnM ()
 452 checkSectionPrec direction section op arg
 453   = case unLoc arg of
 454         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
 455         NegApp _ _       -> go_for_it pp_prefix_minus negateFixity
 456         other            -> returnM ()
 457   where
 458     L _ (HsVar op_name) = op
 459     go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
 460         = lookupFixityRn op_name        `thenM` \ op_fix@(Fixity op_prec _) ->
 461           checkErr (op_prec < arg_prec
 462                      || op_prec == arg_prec && direction == assoc)
 463                   (sectionPrecErr (ppr_op op_name, op_fix)
 464                   (pp_arg_op, arg_fix) section)
 465 \end{code}
 466
 467 Precedence-related error messages
 468
 469 \begin{code}
 470 precParseErr op1 op2
 471   = hang (ptext SLIT("precedence parsing error"))
 472       4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
 473                ppr_opfix op2,
 474                ptext SLIT("in the same infix expression")])
 475
 476 sectionPrecErr op arg_op section
 477  = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
 478          nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
 479          nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
 480
 481 pp_prefix_minus = ptext SLIT("prefix `-'")
 482 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
 483 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
 484 \end{code}
 485
 486 %*********************************************************
 487 %*                                                      *
 488 \subsection{Contexts and predicates}
 489 %*                                                      *
 490 %*********************************************************
 491
 492 \begin{code}
 493 rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
 494 rnContext doc = wrapLocM (rnContext' doc)
 495
 496 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
 497 rnContext' doc ctxt = mappM (rnLPred doc) ctxt
 498
 499 rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
 500 rnLPred doc  = wrapLocM (rnPred doc)
 501
 502 rnPred doc (HsClassP clas tys)
 503   = lookupOccRn clas            `thenM` \ clas_name ->
 504     rnLHsTypes doc tys          `thenM` \ tys' ->
 505     returnM (HsClassP clas_name tys')
 506
 507 rnPred doc (HsIParam n ty)
 508   = newIPNameRn n               `thenM` \ name ->
 509     rnLHsType doc ty            `thenM` \ ty' ->
 510     returnM (HsIParam name ty')
 511 \end{code}
 512
 513
 514 *********************************************************
 515 *                                                       *
 516 \subsection{Patterns}
 517 *                                                       *
 518 *********************************************************
 519
 520 \begin{code}
 521 rnPatsAndThen :: HsMatchContext Name
 522               -> [LPat RdrName]
 523               -> ([LPat Name] -> RnM (a, FreeVars))
 524               -> RnM (a, FreeVars)
 525 -- Bring into scope all the binders and type variables
 526 -- bound by the patterns; then rename the patterns; then
 527 -- do the thing inside.
 528 --
 529 -- Note that we do a single bindLocalsRn for all the
 530 -- matches together, so that we spot the repeated variable in
 531 --      f x x = 1
 532
 533 rnPatsAndThen ctxt pats thing_inside
 534   = bindPatSigTyVarsFV pat_sig_tys      $
 535     bindLocatedLocalsFV doc_pat bndrs   $ \ new_bndrs ->
 536     rnLPats pats                        `thenM` \ (pats', pat_fvs) ->
 537     thing_inside pats'                  `thenM` \ (res, res_fvs) ->
 538
 539     let
 540         unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs
 541     in
 542     warnUnusedMatches unused_binders   `thenM_`
 543     returnM (res, res_fvs `plusFV` pat_fvs)
 544   where
 545     pat_sig_tys = collectSigTysFromPats pats
 546     bndrs       = collectLocatedPatsBinders pats
 547     doc_pat     = ptext SLIT("In") <+> pprMatchContext ctxt
 548
 549 rnLPats :: [LPat RdrName] -> RnM ([LPat Name], FreeVars)
 550 rnLPats ps = mapFvRn rnLPat ps
 551
 552 rnLPat :: LPat RdrName -> RnM (LPat Name, FreeVars)
 553 rnLPat = wrapLocFstM rnPat
 554
 555 -- -----------------------------------------------------------------------------
 556 -- rnPat
 557
 558 rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars)
 559
 560 rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs)
 561
 562 rnPat (VarPat name)
 563   = lookupBndrRn  name                  `thenM` \ vname ->
 564     returnM (VarPat vname, emptyFVs)
 565
 566 rnPat (SigPatIn pat ty)
 567   = doptM Opt_GlasgowExts `thenM` \ glaExts ->
 568
 569     if glaExts
 570     then rnLPat pat             `thenM` \ (pat', fvs1) ->
 571          rnHsTypeFVs doc ty     `thenM` \ (ty',  fvs2) ->
 572          returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
 573
 574     else addErr (patSigErr ty)  `thenM_`
 575          rnPat (unLoc pat) -- XXX shouldn't throw away the loc
 576   where
 577     doc = text "In a pattern type-signature"
 578
 579 rnPat (LitPat lit)
 580   = rnLit lit   `thenM_`
 581     returnM (LitPat lit, emptyFVs)
 582
 583 rnPat (NPat lit mb_neg eq _)
 584   = rnOverLit lit                       `thenM` \ (lit', fvs1) ->
 585     (case mb_neg of
 586         Nothing -> returnM (Nothing, emptyFVs)
 587         Just _  -> lookupSyntaxName negateName  `thenM` \ (neg, fvs) ->
 588                    returnM (Just neg, fvs)
 589     )                                   `thenM` \ (mb_neg', fvs2) ->
 590     lookupSyntaxName eqName             `thenM` \ (eq', fvs3) ->
 591     returnM (NPat lit' mb_neg' eq' placeHolderType,
 592               fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` eqClassName)
 593         -- Needed to find equality on pattern
 594
 595 rnPat (NPlusKPat name lit _ _)
 596   = rnOverLit lit                       `thenM` \ (lit', fvs1) ->
 597     lookupLocatedBndrRn name            `thenM` \ name' ->
 598     lookupSyntaxName minusName          `thenM` \ (minus, fvs2) ->
 599     lookupSyntaxName geName             `thenM` \ (ge, fvs3) ->
 600     returnM (NPlusKPat name' lit' ge minus,
 601              fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` integralClassName)
 602         -- The Report says that n+k patterns must be in Integral
 603
 604 rnPat (LazyPat pat)
 605   = rnLPat pat          `thenM` \ (pat', fvs) ->
 606     returnM (LazyPat pat', fvs)
 607
 608 rnPat (BangPat pat)
 609   = rnLPat pat          `thenM` \ (pat', fvs) ->
 610     returnM (BangPat pat', fvs)
 611
 612 rnPat (AsPat name pat)
 613   = rnLPat pat                  `thenM` \ (pat', fvs) ->
 614     lookupLocatedBndrRn name    `thenM` \ vname ->
 615     returnM (AsPat vname pat', fvs)
 616
 617 rnPat (ConPatIn con stuff) = rnConPat con stuff
 618
 619
 620 rnPat (ParPat pat)
 621   = rnLPat pat          `thenM` \ (pat', fvs) ->
 622     returnM (ParPat pat', fvs)
 623
 624 rnPat (ListPat pats _)
 625   = rnLPats pats                        `thenM` \ (patslist, fvs) ->
 626     returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name)
 627
 628 rnPat (PArrPat pats _)
 629   = rnLPats pats                        `thenM` \ (patslist, fvs) ->
 630     returnM (PArrPat patslist placeHolderType,
 631               fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
 632   where
 633     implicit_fvs = mkFVs [lengthPName, indexPName]
 634
 635 rnPat (TuplePat pats boxed _)
 636   = checkTupSize tup_size       `thenM_`
 637     rnLPats pats                        `thenM` \ (patslist, fvs) ->
 638     returnM (TuplePat patslist boxed placeHolderType,
 639              fvs `addOneFV` tycon_name)
 640   where
 641     tup_size   = length pats
 642     tycon_name = tupleTyCon_name boxed tup_size
 643
 644 rnPat (TypePat name) =
 645     rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->
 646     returnM (TypePat name', fvs)
 647
 648 -- -----------------------------------------------------------------------------
 649 -- rnConPat
 650
 651 rnConPat con (PrefixCon pats)
 652   = lookupLocatedOccRn con      `thenM` \ con' ->
 653     rnLPats pats                `thenM` \ (pats', fvs) ->
 654     returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con')
 655
 656 rnConPat con (RecCon rpats)
 657   = lookupLocatedOccRn con      `thenM` \ con' ->
 658     rnRpats rpats               `thenM` \ (rpats', fvs) ->
 659     returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con')
 660
 661 rnConPat con (InfixCon pat1 pat2)
 662   = lookupLocatedOccRn con                      `thenM` \ con' ->
 663     rnLPat pat1                                 `thenM` \ (pat1', fvs1) ->
 664     rnLPat pat2                                 `thenM` \ (pat2', fvs2) ->
 665     lookupFixityRn (unLoc con')                 `thenM` \ fixity ->
 666     mkConOpPatRn con' fixity pat1' pat2'        `thenM` \ pat' ->
 667     returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con')
 668
 669 -- -----------------------------------------------------------------------------
 670 -- rnRpats
 671
 672 rnRpats :: [(Located RdrName, LPat RdrName)]
 673         -> RnM ([(Located Name, LPat Name)], FreeVars)
 674 rnRpats rpats
 675   = mappM_ field_dup_err dup_fields     `thenM_`
 676     mapFvRn rn_rpat rpats               `thenM` \ (rpats', fvs) ->
 677     returnM (rpats', fvs)
 678   where
 679     (_, dup_fields) = removeDups compare [ unLoc f | (f,_) <- rpats ]
 680
 681     field_dup_err dups = addErr (dupFieldErr "pattern" dups)
 682
 683     rn_rpat (field, pat)
 684       = lookupLocatedGlobalOccRn field  `thenM` \ fieldname ->
 685         rnLPat pat                      `thenM` \ (pat', fvs) ->
 686         returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname)
 687
 688 \end{code}
 689
 690
 691 %************************************************************************
 692 %*                                                                      *
 693 \subsubsection{Literals}
 694 %*                                                                      *
 695 %************************************************************************
 696
 697 When literals occur we have to make sure
 698 that the types and classes they involve
 699 are made available.
 700
 701 \begin{code}
 702 rnLit :: HsLit -> RnM ()
 703 rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
 704 rnLit other      = returnM ()
 705
 706 rnOverLit (HsIntegral i _)
 707   = lookupSyntaxName fromIntegerName    `thenM` \ (from_integer_name, fvs) ->
 708     if inIntRange i then
 709         returnM (HsIntegral i from_integer_name, fvs)
 710     else let
 711         extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
 712         -- Big integer literals are built, using + and *,
 713         -- out of small integers (DsUtils.mkIntegerLit)
 714         -- [NB: plusInteger, timesInteger aren't rebindable...
 715         --      they are used to construct the argument to fromInteger,
 716         --      which is the rebindable one.]
 717     in
 718     returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs)
 719
 720 rnOverLit (HsFractional i _)
 721   = lookupSyntaxName fromRationalName           `thenM` \ (from_rat_name, fvs) ->
 722     let
 723         extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
 724         -- We have to make sure that the Ratio type is imported with
 725         -- its constructor, because literals of type Ratio t are
 726         -- built with that constructor.
 727         -- The Rational type is needed too, but that will come in
 728         -- as part of the type for fromRational.
 729         -- The plus/times integer operations may be needed to construct the numerator
 730         -- and denominator (see DsUtils.mkIntegerLit)
 731     in
 732     returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
 733 \end{code}
 734
 735
 736
 737 %*********************************************************
 738 %*                                                      *
 739 \subsection{Errors}
 740 %*                                                      *
 741 %*********************************************************
 742
 743 \begin{code}
 744 checkTupSize :: Int -> RnM ()
 745 checkTupSize tup_size
 746   | tup_size <= mAX_TUPLE_SIZE
 747   = returnM ()
 748   | otherwise
 749   = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"),
 750                  nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)),
 751                  nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))])
 752
 753 forAllWarn doc ty (L loc tyvar)
 754   = ifOptM Opt_WarnUnusedMatches        $
 755     setSrcSpan loc $
 756     addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 757                    nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 758                    $$
 759                    doc
 760                 )
 761
 762 bogusCharError c
 763   = ptext SLIT("character literal out of range: '\\") <> char c  <> char '\''
 764
 765 patSigErr ty
 766   =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
 767         $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
 768
 769 dupFieldErr str dup
 770   = hsep [ptext SLIT("duplicate field name"),
 771           quotes (ppr dup),
 772           ptext SLIT("in record"), text str]
 773 \end{code}