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