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