ghc/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 rnLHsTypes doc tys = mappM (rnLHsType doc) tys
 189 \end{code}
 190
 191
 192 \begin{code}
 193 rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
 194          -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
 195
 196 rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty
 197         -- One reason for this case is that a type like Int#
 198         -- starts off as (HsForAllTy Nothing [] Int), in case
 199         -- there is some quantification.  Now that we have quantified
 200         -- and discovered there are no type variables, it's nicer to turn
 201         -- it into plain Int.  If it were Int# instead of Int, we'd actually
 202         -- get an error, because the body of a genuine for-all is
 203         -- of kind *.
 204
 205 rnForAll doc exp forall_tyvars ctxt ty
 206   = bindTyVarsRn doc forall_tyvars      $ \ new_tyvars ->
 207     rnContext doc ctxt                  `thenM` \ new_ctxt ->
 208     rnLHsType doc ty                    `thenM` \ new_ty ->
 209     returnM (HsForAllTy exp new_tyvars new_ctxt new_ty)
 210         -- Retain the same implicit/explicit flag as before
 211         -- so that we can later print it correctly
 212 \end{code}
 213
 214
 215 %************************************************************************
 216 %*                                                                      *
 217         Fixities and precedence parsing
 218 %*                                                                      *
 219 %************************************************************************
 220
 221 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 222 are assumed to be already correctly arranged.  It needs the fixities
 223 recorded in the OpApp nodes, because fixity info applies to the things
 224 the programmer actually wrote, so you can't find it out from the Name.
 225
 226 Furthermore, the second argument is guaranteed not to be another
 227 operator application.  Why? Because the parser parses all
 228 operator appications left-associatively, EXCEPT negation, which
 229 we need to handle specially.
 230 Infix types are read in a *right-associative* way, so that
 231         a `op` b `op` c
 232 is always read in as
 233         a `op` (b `op` c)
 234
 235 mkHsOpTyRn rearranges where necessary.  The two arguments
 236 have already been renamed and rearranged.  It's made rather tiresome
 237 by the presence of ->, which is a separate syntactic construct.
 238
 239 \begin{code}
 240 ---------------
 241 -- Building (ty1 `op1` (ty21 `op2` ty22))
 242 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
 243            -> SDoc -> Fixity -> LHsType Name -> LHsType Name
 244            -> RnM (HsType Name)
 245
 246 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
 247   = do  { fix2 <- lookupTyFixityRn op2
 248         ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
 249                       (\t1 t2 -> HsOpTy t1 op2 t2)
 250                       (ppr op2) fix2 ty21 ty22 loc2 }
 251
 252 mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2@(L loc2 (HsFunTy ty21 ty22))
 253   = mk_hs_op_ty mk1 pp_op1 fix1 ty1
 254                 HsFunTy (ppr funTyCon) funTyFixity ty21 ty22 loc2
 255
 256 mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2              -- Default case, no rearrangment
 257   = return (mk1 ty1 ty2)
 258
 259 ---------------
 260 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
 261             -> SDoc -> Fixity -> LHsType Name
 262             -> (LHsType Name -> LHsType Name -> HsType Name)
 263             -> SDoc -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
 264             -> RnM (HsType Name)
 265 mk_hs_op_ty mk1 pp_op1 fix1 ty1
 266             mk2 pp_op2 fix2 ty21 ty22 loc2
 267   | nofix_error     = do { addErr (precParseErr (quotes pp_op1,fix1)
 268                                                 (quotes pp_op2,fix2))
 269                          ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
 270   | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
 271   | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
 272                            new_ty <- mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty21
 273                          ; return (mk2 (noLoc new_ty) ty22) }
 274   where
 275     (nofix_error, associate_right) = compareFixity fix1 fix2
 276
 277
 278 ---------------------------
 279 mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged
 280           -> LHsExpr Name -> Fixity             -- Operator and fixity
 281           -> LHsExpr Name                       -- Right operand (not an OpApp, but might
 282                                                 -- be a NegApp)
 283           -> RnM (HsExpr Name)
 284
 285 -- (e11 `op1` e12) `op2` e2
 286 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
 287   | nofix_error
 288   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
 289     returnM (OpApp e1 op2 fix2 e2)
 290
 291   | associate_right
 292   = mkOpAppRn e12 op2 fix2 e2           `thenM` \ new_e ->
 293     returnM (OpApp e11 op1 fix1 (L loc' new_e))
 294   where
 295     loc'= combineLocs e12 e2
 296     (nofix_error, associate_right) = compareFixity fix1 fix2
 297
 298 ---------------------------
 299 --      (- neg_arg) `op` e2
 300 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
 301   | nofix_error
 302   = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))      `thenM_`
 303     returnM (OpApp e1 op2 fix2 e2)
 304
 305   | associate_right
 306   = mkOpAppRn neg_arg op2 fix2 e2       `thenM` \ new_e ->
 307     returnM (NegApp (L loc' new_e) neg_name)
 308   where
 309     loc' = combineLocs neg_arg e2
 310     (nofix_error, associate_right) = compareFixity negateFixity fix2
 311
 312 ---------------------------
 313 --      e1 `op` - neg_arg
 314 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _))       -- NegApp can occur on the right
 315   | not associate_right                         -- We *want* right association
 316   = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))    `thenM_`
 317     returnM (OpApp e1 op1 fix1 e2)
 318   where
 319     (_, associate_right) = compareFixity fix1 negateFixity
 320
 321 ---------------------------
 322 --      Default case
 323 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 324   = ASSERT2( right_op_ok fix (unLoc e2),
 325              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
 326     )
 327     returnM (OpApp e1 op fix e2)
 328
 329 -- Parser left-associates everything, but
 330 -- derived instances may have correctly-associated things to
 331 -- in the right operarand.  So we just check that the right operand is OK
 332 right_op_ok fix1 (OpApp _ _ fix2 _)
 333   = not error_please && associate_right
 334   where
 335     (error_please, associate_right) = compareFixity fix1 fix2
 336 right_op_ok fix1 other
 337   = True
 338
 339 -- Parser initially makes negation bind more tightly than any other operator
 340 -- And "deriving" code should respect this (use HsPar if not)
 341 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
 342 mkNegAppRn neg_arg neg_name
 343   = ASSERT( not_op_app (unLoc neg_arg) )
 344     returnM (NegApp neg_arg neg_name)
 345
 346 not_op_app (OpApp _ _ _ _) = False
 347 not_op_app other           = True
 348
 349 ---------------------------
 350 mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
 351           -> LHsExpr Name -> Fixity     -- Operator and fixity
 352           -> LHsCmdTop Name             -- Right operand (not an infix)
 353           -> RnM (HsCmd Name)
 354
 355 -- (e11 `op1` e12) `op2` e2
 356 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
 357         op2 fix2 a2
 358   | nofix_error
 359   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
 360     returnM (HsArrForm op2 (Just fix2) [a1, a2])
 361
 362   | associate_right
 363   = mkOpFormRn a12 op2 fix2 a2          `thenM` \ new_c ->
 364     returnM (HsArrForm op1 (Just fix1)
 365         [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
 366         -- TODO: locs are wrong
 367   where
 368     (nofix_error, associate_right) = compareFixity fix1 fix2
 369
 370 --      Default case
 371 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
 372   = returnM (HsArrForm op (Just fix) [arg1, arg2])
 373
 374
 375 --------------------------------------
 376 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
 377              -> RnM (Pat Name)
 378
 379 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
 380   = lookupFixityRn (unLoc op1)  `thenM` \ fix1 ->
 381     let
 382         (nofix_error, associate_right) = compareFixity fix1 fix2
 383     in
 384     if nofix_error then
 385         addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))       `thenM_`
 386         returnM (ConPatIn op2 (InfixCon p1 p2))
 387     else
 388     if associate_right then
 389         mkConOpPatRn op2 fix2 p12 p2            `thenM` \ new_p ->
 390         returnM (ConPatIn op1 (InfixCon p11 (L loc new_p)))  -- XXX loc right?
 391     else
 392     returnM (ConPatIn op2 (InfixCon p1 p2))
 393
 394 mkConOpPatRn op fix p1 p2                       -- Default case, no rearrangment
 395   = ASSERT( not_op_pat (unLoc p2) )
 396     returnM (ConPatIn op (InfixCon p1 p2))
 397
 398 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
 399 not_op_pat other                       = True
 400
 401 --------------------------------------
 402 checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
 403         -- True indicates an infix lhs
 404         -- See comments with rnExpr (OpApp ...) about "deriving"
 405
 406 checkPrecMatch False fn match
 407   = returnM ()
 408 checkPrecMatch True op (MatchGroup ms _)
 409   = mapM_ check ms
 410   where
 411     check (L _ (Match (p1:p2:_) _ _))
 412       = checkPrec op (unLoc p1) False   `thenM_`
 413         checkPrec op (unLoc p2) True
 414
 415     check _ = panic "checkPrecMatch"
 416
 417 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
 418   = lookupFixityRn op           `thenM` \  op_fix@(Fixity op_prec  op_dir) ->
 419     lookupFixityRn (unLoc op1)  `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
 420     let
 421         inf_ok = op1_prec > op_prec ||
 422                  (op1_prec == op_prec &&
 423                   (op1_dir == InfixR && op_dir == InfixR && right ||
 424                    op1_dir == InfixL && op_dir == InfixL && not right))
 425
 426         info  = (ppr_op op,  op_fix)
 427         info1 = (ppr_op op1, op1_fix)
 428         (infol, infor) = if right then (info, info1) else (info1, info)
 429     in
 430     checkErr inf_ok (precParseErr infol infor)
 431
 432 checkPrec op pat right
 433   = returnM ()
 434
 435 -- Check precedence of (arg op) or (op arg) respectively
 436 -- If arg is itself an operator application, then either
 437 --   (a) its precedence must be higher than that of op
 438 --   (b) its precedency & associativity must be the same as that of op
 439 checkSectionPrec :: FixityDirection -> HsExpr RdrName
 440         -> LHsExpr Name -> LHsExpr Name -> RnM ()
 441 checkSectionPrec direction section op arg
 442   = case unLoc arg of
 443         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
 444         NegApp _ _       -> go_for_it pp_prefix_minus negateFixity
 445         other            -> returnM ()
 446   where
 447     L _ (HsVar op_name) = op
 448     go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
 449         = lookupFixityRn op_name        `thenM` \ op_fix@(Fixity op_prec _) ->
 450           checkErr (op_prec < arg_prec
 451                      || op_prec == arg_prec && direction == assoc)
 452                   (sectionPrecErr (ppr_op op_name, op_fix)
 453                   (pp_arg_op, arg_fix) section)
 454 \end{code}
 455
 456 Precedence-related error messages
 457
 458 \begin{code}
 459 precParseErr op1 op2
 460   = hang (ptext SLIT("precedence parsing error"))
 461       4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
 462                ppr_opfix op2,
 463                ptext SLIT("in the same infix expression")])
 464
 465 sectionPrecErr op arg_op section
 466  = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
 467          nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
 468          nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
 469
 470 pp_prefix_minus = ptext SLIT("prefix `-'")
 471 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
 472 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
 473 \end{code}
 474
 475 %*********************************************************
 476 %*                                                      *
 477 \subsection{Contexts and predicates}
 478 %*                                                      *
 479 %*********************************************************
 480
 481 \begin{code}
 482 rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
 483 rnContext doc = wrapLocM (rnContext' doc)
 484
 485 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
 486 rnContext' doc ctxt = mappM (rnLPred doc) ctxt
 487
 488 rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
 489 rnLPred doc  = wrapLocM (rnPred doc)
 490
 491 rnPred doc (HsClassP clas tys)
 492   = lookupOccRn clas            `thenM` \ clas_name ->
 493     rnLHsTypes doc tys          `thenM` \ tys' ->
 494     returnM (HsClassP clas_name tys')
 495
 496 rnPred doc (HsIParam n ty)
 497   = newIPNameRn n               `thenM` \ name ->
 498     rnLHsType doc ty            `thenM` \ ty' ->
 499     returnM (HsIParam name ty')
 500 \end{code}
 501
 502
 503 *********************************************************
 504 *                                                       *
 505 \subsection{Patterns}
 506 *                                                       *
 507 *********************************************************
 508
 509 \begin{code}
 510 rnPatsAndThen :: HsMatchContext Name
 511               -> [LPat RdrName]
 512               -> ([LPat Name] -> RnM (a, FreeVars))
 513               -> RnM (a, FreeVars)
 514 -- Bring into scope all the binders and type variables
 515 -- bound by the patterns; then rename the patterns; then
 516 -- do the thing inside.
 517 --
 518 -- Note that we do a single bindLocalsRn for all the
 519 -- matches together, so that we spot the repeated variable in
 520 --      f x x = 1
 521
 522 rnPatsAndThen ctxt pats thing_inside
 523   = bindPatSigTyVarsFV pat_sig_tys      $
 524     bindLocatedLocalsFV doc_pat bndrs   $ \ new_bndrs ->
 525     rnLPats pats                        `thenM` \ (pats', pat_fvs) ->
 526     thing_inside pats'                  `thenM` \ (res, res_fvs) ->
 527
 528     let
 529         unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs
 530     in
 531     warnUnusedMatches unused_binders   `thenM_`
 532     returnM (res, res_fvs `plusFV` pat_fvs)
 533   where
 534     pat_sig_tys = collectSigTysFromPats pats
 535     bndrs       = collectLocatedPatsBinders pats
 536     doc_pat     = ptext SLIT("In") <+> pprMatchContext ctxt
 537
 538 rnLPats :: [LPat RdrName] -> RnM ([LPat Name], FreeVars)
 539 rnLPats ps = mapFvRn rnLPat ps
 540
 541 rnLPat :: LPat RdrName -> RnM (LPat Name, FreeVars)
 542 rnLPat = wrapLocFstM rnPat
 543
 544 -- -----------------------------------------------------------------------------
 545 -- rnPat
 546
 547 rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars)
 548
 549 rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs)
 550
 551 rnPat (VarPat name)
 552   = lookupBndrRn  name                  `thenM` \ vname ->
 553     returnM (VarPat vname, emptyFVs)
 554
 555 rnPat (SigPatIn pat ty)
 556   = doptM Opt_GlasgowExts `thenM` \ glaExts ->
 557
 558     if glaExts
 559     then rnLPat pat             `thenM` \ (pat', fvs1) ->
 560          rnHsTypeFVs doc ty     `thenM` \ (ty',  fvs2) ->
 561          returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
 562
 563     else addErr (patSigErr ty)  `thenM_`
 564          rnPat (unLoc pat) -- XXX shouldn't throw away the loc
 565   where
 566     doc = text "In a pattern type-signature"
 567
 568 rnPat (LitPat lit)
 569   = rnLit lit   `thenM_`
 570     returnM (LitPat lit, emptyFVs)
 571
 572 rnPat (NPat lit mb_neg eq _)
 573   = rnOverLit lit                       `thenM` \ (lit', fvs1) ->
 574     (case mb_neg of
 575         Nothing -> returnM (Nothing, emptyFVs)
 576         Just _  -> lookupSyntaxName negateName  `thenM` \ (neg, fvs) ->
 577                    returnM (Just neg, fvs)
 578     )                                   `thenM` \ (mb_neg', fvs2) ->
 579     lookupSyntaxName eqName             `thenM` \ (eq', fvs3) ->
 580     returnM (NPat lit' mb_neg' eq' placeHolderType,
 581               fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` eqClassName)
 582         -- Needed to find equality on pattern
 583
 584 rnPat (NPlusKPat name lit _ _)
 585   = rnOverLit lit                       `thenM` \ (lit', fvs1) ->
 586     lookupLocatedBndrRn name            `thenM` \ name' ->
 587     lookupSyntaxName minusName          `thenM` \ (minus, fvs2) ->
 588     lookupSyntaxName geName             `thenM` \ (ge, fvs3) ->
 589     returnM (NPlusKPat name' lit' ge minus,
 590              fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` integralClassName)
 591         -- The Report says that n+k patterns must be in Integral
 592
 593 rnPat (LazyPat pat)
 594   = rnLPat pat          `thenM` \ (pat', fvs) ->
 595     returnM (LazyPat pat', fvs)
 596
 597 rnPat (AsPat name pat)
 598   = rnLPat pat                  `thenM` \ (pat', fvs) ->
 599     lookupLocatedBndrRn name    `thenM` \ vname ->
 600     returnM (AsPat vname pat', fvs)
 601
 602 rnPat (ConPatIn con stuff) = rnConPat con stuff
 603
 604
 605 rnPat (ParPat pat)
 606   = rnLPat pat          `thenM` \ (pat', fvs) ->
 607     returnM (ParPat pat', fvs)
 608
 609 rnPat (ListPat pats _)
 610   = rnLPats pats                        `thenM` \ (patslist, fvs) ->
 611     returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name)
 612
 613 rnPat (PArrPat pats _)
 614   = rnLPats pats                        `thenM` \ (patslist, fvs) ->
 615     returnM (PArrPat patslist placeHolderType,
 616               fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
 617   where
 618     implicit_fvs = mkFVs [lengthPName, indexPName]
 619
 620 rnPat (TuplePat pats boxed _)
 621   = checkTupSize tup_size       `thenM_`
 622     rnLPats pats                        `thenM` \ (patslist, fvs) ->
 623     returnM (TuplePat patslist boxed placeHolderType,
 624              fvs `addOneFV` tycon_name)
 625   where
 626     tup_size   = length pats
 627     tycon_name = tupleTyCon_name boxed tup_size
 628
 629 rnPat (TypePat name) =
 630     rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->
 631     returnM (TypePat name', fvs)
 632
 633 -- -----------------------------------------------------------------------------
 634 -- rnConPat
 635
 636 rnConPat con (PrefixCon pats)
 637   = lookupLocatedOccRn con      `thenM` \ con' ->
 638     rnLPats pats                `thenM` \ (pats', fvs) ->
 639     returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con')
 640
 641 rnConPat con (RecCon rpats)
 642   = lookupLocatedOccRn con      `thenM` \ con' ->
 643     rnRpats rpats               `thenM` \ (rpats', fvs) ->
 644     returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con')
 645
 646 rnConPat con (InfixCon pat1 pat2)
 647   = lookupLocatedOccRn con                      `thenM` \ con' ->
 648     rnLPat pat1                                 `thenM` \ (pat1', fvs1) ->
 649     rnLPat pat2                                 `thenM` \ (pat2', fvs2) ->
 650     lookupFixityRn (unLoc con')                 `thenM` \ fixity ->
 651     mkConOpPatRn con' fixity pat1' pat2'        `thenM` \ pat' ->
 652     returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con')
 653
 654 -- -----------------------------------------------------------------------------
 655 -- rnRpats
 656
 657 rnRpats :: [(Located RdrName, LPat RdrName)]
 658         -> RnM ([(Located Name, LPat Name)], FreeVars)
 659 rnRpats rpats
 660   = mappM_ field_dup_err dup_fields     `thenM_`
 661     mapFvRn rn_rpat rpats               `thenM` \ (rpats', fvs) ->
 662     returnM (rpats', fvs)
 663   where
 664     (_, dup_fields) = removeDups compare [ unLoc f | (f,_) <- rpats ]
 665
 666     field_dup_err dups = addErr (dupFieldErr "pattern" dups)
 667
 668     rn_rpat (field, pat)
 669       = lookupLocatedGlobalOccRn field  `thenM` \ fieldname ->
 670         rnLPat pat                      `thenM` \ (pat', fvs) ->
 671         returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname)
 672
 673 \end{code}
 674
 675
 676 %************************************************************************
 677 %*                                                                      *
 678 \subsubsection{Literals}
 679 %*                                                                      *
 680 %************************************************************************
 681
 682 When literals occur we have to make sure
 683 that the types and classes they involve
 684 are made available.
 685
 686 \begin{code}
 687 rnLit :: HsLit -> RnM ()
 688 rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
 689 rnLit other      = returnM ()
 690
 691 rnOverLit (HsIntegral i _)
 692   = lookupSyntaxName fromIntegerName    `thenM` \ (from_integer_name, fvs) ->
 693     if inIntRange i then
 694         returnM (HsIntegral i from_integer_name, fvs)
 695     else let
 696         extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
 697         -- Big integer literals are built, using + and *,
 698         -- out of small integers (DsUtils.mkIntegerLit)
 699         -- [NB: plusInteger, timesInteger aren't rebindable...
 700         --      they are used to construct the argument to fromInteger,
 701         --      which is the rebindable one.]
 702     in
 703     returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs)
 704
 705 rnOverLit (HsFractional i _)
 706   = lookupSyntaxName fromRationalName           `thenM` \ (from_rat_name, fvs) ->
 707     let
 708         extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
 709         -- We have to make sure that the Ratio type is imported with
 710         -- its constructor, because literals of type Ratio t are
 711         -- built with that constructor.
 712         -- The Rational type is needed too, but that will come in
 713         -- as part of the type for fromRational.
 714         -- The plus/times integer operations may be needed to construct the numerator
 715         -- and denominator (see DsUtils.mkIntegerLit)
 716     in
 717     returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
 718 \end{code}
 719
 720
 721
 722 %*********************************************************
 723 %*                                                      *
 724 \subsection{Errors}
 725 %*                                                      *
 726 %*********************************************************
 727
 728 \begin{code}
 729 checkTupSize :: Int -> RnM ()
 730 checkTupSize tup_size
 731   | tup_size <= mAX_TUPLE_SIZE
 732   = returnM ()
 733   | otherwise
 734   = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"),
 735                  nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)),
 736                  nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))])
 737
 738 forAllWarn doc ty (L loc tyvar)
 739   = ifOptM Opt_WarnUnusedMatches        $
 740     setSrcSpan loc $
 741     addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 742                    nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 743                    $$
 744                    doc
 745                 )
 746
 747 bogusCharError c
 748   = ptext SLIT("character literal out of range: '\\") <> char c  <> char '\''
 749
 750 patSigErr ty
 751   =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
 752         $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
 753
 754 dupFieldErr str dup
 755   = hsep [ptext SLIT("duplicate field name"),
 756           quotes (ppr dup),
 757           ptext SLIT("in record"), text str]
 758 \end{code}