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