ghc/compiler/rename/RnSource.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 RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
   8
   9 #include "HsVersions.h"
  10
  11 import RnExpr
  12 import HsSyn
  13 import HsTypes          ( hsTyVarNames, pprHsContext )
  14 import RdrName          ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr )
  15 import RdrHsSyn         ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
  16                           extractRuleBndrsTyVars, extractHsTyRdrTyVars,
  17                           extractHsCtxtRdrTyVars, extractGenericPatTyVars
  18                         )
  19 import RnHsSyn
  20 import HsCore
  21
  22 import RnBinds          ( rnTopBinds, rnMethodBinds, renameSigs )
  23 import RnEnv            ( lookupTopBndrRn, lookupOccRn, newIPName,
  24                           lookupOrigNames, lookupSysBinder, newLocalsRn,
  25                           bindLocalsFVRn, bindUVarRn,
  26                           bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
  27                           bindCoreLocalFVRn, bindCoreLocalsFVRn, bindLocalNames,
  28                           checkDupOrQualNames, checkDupNames,
  29                           FreeVars, emptyFVs, plusFV, plusFVs, unitFV,
  30                           addOneFV, mapFvRn
  31                         )
  32 import RnMonad
  33
  34 import FunDeps          ( oclose )
  35 import Class            ( FunDep, DefMeth (..) )
  36 import Name             ( Name, OccName, nameOccName, NamedThing(..) )
  37 import NameSet
  38 import FiniteMap        ( elemFM )
  39 import PrelInfo         ( derivableClassKeys, cCallishClassKeys )
  40 import PrelNames        ( deRefStablePtr_RDR, makeStablePtr_RDR,
  41                           bindIO_RDR, returnIO_RDR
  42                         )
  43 import List             ( partition, nub )
  44 import Outputable
  45 import SrcLoc           ( SrcLoc )
  46 import CmdLineOpts      ( DynFlag(..) )
  47                                 -- Warn of unused for-all'd tyvars
  48 import Unique           ( Uniquable(..) )
  49 import ErrUtils         ( Message )
  50 import CStrings         ( isCLabelString )
  51 import ListSetOps       ( removeDupsEq )
  52 \end{code}
  53
  54 @rnDecl@ `renames' declarations.
  55 It simultaneously performs dependency analysis and precedence parsing.
  56 It also does the following error checks:
  57 \begin{enumerate}
  58 \item
  59 Checks that tyvars are used properly. This includes checking
  60 for undefined tyvars, and tyvars in contexts that are ambiguous.
  61 (Some of this checking has now been moved to module @TcMonoType@,
  62 since we don't have functional dependency information at this point.)
  63 \item
  64 Checks that all variable occurences are defined.
  65 \item
  66 Checks the @(..)@ etc constraints in the export list.
  67 \end{enumerate}
  68
  69
  70 %*********************************************************
  71 %*                                                      *
  72 \subsection{Value declarations}
  73 %*                                                      *
  74 %*********************************************************
  75
  76 \begin{code}
  77 rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
  78         -- The decls get reversed, but that's ok
  79
  80 rnSourceDecls decls
  81   = go emptyFVs [] decls
  82   where
  83         -- Fixity and deprecations have been dealt with already; ignore them
  84     go fvs ds' []             = returnRn (ds', fvs)
  85     go fvs ds' (FixD _:ds)    = go fvs ds' ds
  86     go fvs ds' (DeprecD _:ds) = go fvs ds' ds
  87     go fvs ds' (d:ds)         = rnDecl d        `thenRn` \(d', fvs') ->
  88                                 go (fvs `plusFV` fvs') (d':ds') ds
  89 \end{code}
  90
  91
  92 %*********************************************************
  93 %*                                                      *
  94 \subsection{Value declarations}
  95 %*                                                      *
  96 %*********************************************************
  97
  98 \begin{code}
  99 -- rnDecl does all the work
 100 rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
 101
 102 rnDecl (ValD binds) = rnTopBinds binds  `thenRn` \ (new_binds, fvs) ->
 103                       returnRn (ValD new_binds, fvs)
 104
 105
 106 rnDecl (SigD (IfaceSig name ty id_infos loc))
 107   = pushSrcLocRn loc $
 108     lookupTopBndrRn name                `thenRn` \ name' ->
 109     rnHsType doc_str ty                 `thenRn` \ (ty',fvs1) ->
 110     mapFvRn rnIdInfo id_infos           `thenRn` \ (id_infos', fvs2) ->
 111     returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
 112   where
 113     doc_str = text "the interface signature for" <+> quotes (ppr name)
 114 \end{code}
 115
 116 %*********************************************************
 117 %*                                                      *
 118 \subsection{Type declarations}
 119 %*                                                      *
 120 %*********************************************************
 121
 122 @rnTyDecl@ uses the `global name function' to create a new type
 123 declaration in which local names have been replaced by their original
 124 names, reporting any unknown names.
 125
 126 Renaming type variables is a pain. Because they now contain uniques,
 127 it is necessary to pass in an association list which maps a parsed
 128 tyvar to its @Name@ representation.
 129 In some cases (type signatures of values),
 130 it is even necessary to go over the type first
 131 in order to get the set of tyvars used by it, make an assoc list,
 132 and then go over it again to rename the tyvars!
 133 However, we can also do some scoping checks at the same time.
 134
 135 \begin{code}
 136 rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2))
 137   = pushSrcLocRn src_loc $
 138     lookupTopBndrRn tycon                       `thenRn` \ tycon' ->
 139     bindTyVarsFVRn data_doc tyvars              $ \ tyvars' ->
 140     rnContext data_doc context                  `thenRn` \ (context', cxt_fvs) ->
 141     checkDupOrQualNames data_doc con_names      `thenRn_`
 142     mapFvRn rnConDecl condecls                  `thenRn` \ (condecls', con_fvs) ->
 143     lookupSysBinder gen_name1                   `thenRn` \ name1' ->
 144     lookupSysBinder gen_name2                   `thenRn` \ name2' ->
 145     rnDerivs derivings                          `thenRn` \ (derivings', deriv_fvs) ->
 146     returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
 147                      derivings' src_loc name1' name2'),
 148               cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
 149   where
 150     data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
 151     con_names = map conDeclName condecls
 152
 153 rnDecl (TyClD (TySynonym name tyvars ty src_loc))
 154   = pushSrcLocRn src_loc $
 155     doptRn Opt_GlasgowExts                      `thenRn` \ glaExts ->
 156     lookupTopBndrRn name                        `thenRn` \ name' ->
 157     bindTyVarsFVRn syn_doc tyvars               $ \ tyvars' ->
 158     rnHsType syn_doc (unquantify glaExts ty)    `thenRn` \ (ty', ty_fvs) ->
 159     returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
 160   where
 161     syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 162
 163         -- For H98 we do *not* universally quantify on the RHS of a synonym
 164         -- Silently discard context... but the tyvars in the rest won't be in scope
 165     unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
 166     unquantify glaExys ty                                     = ty
 167
 168 rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds names src_loc))
 169   = pushSrcLocRn src_loc $
 170
 171     lookupTopBndrRn cname                       `thenRn` \ cname' ->
 172
 173         -- Deal with the implicit tycon and datacon name
 174         -- They aren't in scope (because they aren't visible to the user)
 175         -- and what we want to do is simply look them up in the cache;
 176         -- we jolly well ought to get a 'hit' there!
 177         -- So the 'Imported' part of this call is not relevant.
 178         -- Unclean; but since these two are the only place this happens
 179         -- I can't work up the energy to do it more beautifully
 180
 181     mapRn lookupSysBinder names         `thenRn` \ names' ->
 182
 183         -- Tyvars scope over bindings and context
 184     bindTyVarsFV2Rn cls_doc tyvars              ( \ clas_tyvar_names tyvars' ->
 185
 186         -- Check the superclasses
 187     rnContext cls_doc context                   `thenRn` \ (context', cxt_fvs) ->
 188
 189         -- Check the functional dependencies
 190     rnFds cls_doc fds                           `thenRn` \ (fds', fds_fvs) ->
 191
 192         -- Check the signatures
 193         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 194     let
 195         (op_sigs, non_op_sigs) = partition isClassOpSig sigs
 196         sig_rdr_names_w_locs   = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
 197     in
 198     checkDupOrQualNames sig_doc sig_rdr_names_w_locs      `thenRn_`
 199     mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs  `thenRn` \ (sigs', sig_fvs) ->
 200     let
 201         binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
 202     in
 203     renameSigs (okClsDclSig binders) non_op_sigs          `thenRn` \ (non_ops', fix_fvs) ->
 204
 205         -- Check the methods
 206         -- The newLocals call is tiresome: given a generic class decl
 207         --      class C a where
 208         --        op :: a -> a
 209         --        op {| x+y |} (Inl a) = ...
 210         --        op {| x+y |} (Inr b) = ...
 211         --        op {| a*b |} (a*b)   = ...
 212         -- we want to name both "x" tyvars with the same unique, so that they are
 213         -- easy to group together in the typechecker.
 214         -- Hence the
 215     getLocalNameEnv                                     `thenRn` \ name_env ->
 216     let
 217         meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
 218         gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
 219                                                 not (tv `elemFM` name_env)]
 220     in
 221     checkDupOrQualNames meth_doc meth_rdr_names_w_locs  `thenRn_`
 222     newLocalsRn mkLocalName gen_rdr_tyvars_w_locs       `thenRn` \ gen_tyvars ->
 223     rnMethodBinds gen_tyvars mbinds                     `thenRn` \ (mbinds', meth_fvs) ->
 224
 225         -- Typechecker is responsible for checking that we only
 226         -- give default-method bindings for things in this class.
 227         -- The renamer *could* check this for class decls, but can't
 228         -- for instance decls.
 229
 230     returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
 231                                names' src_loc),
 232               sig_fvs   `plusFV`
 233
 234               fix_fvs   `plusFV`
 235               cxt_fvs   `plusFV`
 236               fds_fvs   `plusFV`
 237               meth_fvs
 238              )
 239     )
 240   where
 241     cls_doc  = text "the declaration for class"         <+> ppr cname
 242     sig_doc  = text "the signatures for class"          <+> ppr cname
 243     meth_doc = text "the default-methods for class"     <+> ppr cname
 244
 245     rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn)
 246       = pushSrcLocRn locn $
 247         lookupTopBndrRn op                      `thenRn` \ op_name ->
 248
 249                 -- Check the signature
 250         rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
 251         let
 252             check_in_op_ty clas_tyvar =
 253                  checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
 254                          (classTyVarNotInOpTyErr clas_tyvar sig)
 255         in
 256         mapRn_ check_in_op_ty clas_tyvars                `thenRn_`
 257
 258                 -- Make the default-method name
 259         (case maybe_dm_stuff of
 260             Nothing -> returnRn (Nothing, emptyFVs)             -- Source-file class decl
 261
 262             Just (DefMeth dm_rdr_name)
 263                 ->      -- Imported class that has a default method decl
 264                         -- See comments with tname, snames, above
 265                     lookupSysBinder dm_rdr_name         `thenRn` \ dm_name ->
 266                     returnRn (Just (DefMeth dm_name), unitFV dm_name)
 267                         -- An imported class decl for a class decl that had an explicit default
 268                         -- method, mentions, rather than defines,
 269                         -- the default method, so we must arrange to pull it in
 270             Just GenDefMeth
 271                 -> returnRn (Just GenDefMeth, emptyFVs)
 272             Just NoDefMeth
 273                 -> returnRn (Just NoDefMeth, emptyFVs)
 274         )                                               `thenRn` \ (maybe_dm_stuff', dm_fvs) ->
 275
 276         returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn, op_ty_fvs `plusFV` dm_fvs)
 277 \end{code}
 278
 279
 280 %*********************************************************
 281 %*                                                      *
 282 \subsection{Instance declarations}
 283 %*                                                      *
 284 %*********************************************************
 285
 286 \begin{code}
 287 rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc))
 288   = pushSrcLocRn src_loc $
 289     rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
 290     let
 291         inst_tyvars = case inst_ty' of
 292                         HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
 293                         other                             -> []
 294         -- (Slightly strangely) the forall-d tyvars scope over
 295         -- the method bindings too
 296     in
 297
 298         -- Rename the bindings
 299         -- NB meth_names can be qualified!
 300     checkDupNames meth_doc meth_names           `thenRn_`
 301     extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (
 302         rnMethodBinds [] mbinds
 303     )                                           `thenRn` \ (mbinds', meth_fvs) ->
 304     let
 305         binders    = collectMonoBinders mbinds'
 306         binder_set = mkNameSet binders
 307     in
 308         -- Rename the prags and signatures.
 309         -- Note that the type variables are not in scope here,
 310         -- so that      instance Eq a => Eq (T a) where
 311         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 312         -- works OK.
 313         --
 314         -- But the (unqualified) method names are in scope
 315     bindLocalNames binders (
 316        renameSigs (okInstDclSig binder_set) uprags
 317     )                                                   `thenRn` \ (new_uprags, prag_fvs) ->
 318
 319     (case maybe_dfun_rdr_name of
 320         Nothing            -> returnRn (Nothing, emptyFVs)
 321
 322         Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name     `thenRn` \ dfun_name ->
 323                               returnRn (Just dfun_name, unitFV dfun_name)
 324     )                                                   `thenRn` \ (maybe_dfun_name, dfun_fv) ->
 325
 326     -- The typechecker checks that all the bindings are for the right class.
 327     returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc),
 328               inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
 329   where
 330     meth_doc   = text "the bindings in an instance declaration"
 331     meth_names = collectLocatedMonoBinders mbinds
 332 \end{code}
 333
 334 %*********************************************************
 335 %*                                                      *
 336 \subsection{Default declarations}
 337 %*                                                      *
 338 %*********************************************************
 339
 340 \begin{code}
 341 rnDecl (DefD (DefaultDecl tys src_loc))
 342   = pushSrcLocRn src_loc $
 343     rnHsTypes doc_str tys               `thenRn` \ (tys', fvs) ->
 344     returnRn (DefD (DefaultDecl tys' src_loc), fvs)
 345   where
 346     doc_str = text "a `default' declaration"
 347 \end{code}
 348
 349 %*********************************************************
 350 %*                                                      *
 351 \subsection{Foreign declarations}
 352 %*                                                      *
 353 %*********************************************************
 354
 355 \begin{code}
 356 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
 357   = pushSrcLocRn src_loc $
 358     lookupOccRn name                    `thenRn` \ name' ->
 359     let
 360         extra_fvs FoExport
 361           | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR,
 362                                      bindIO_RDR, returnIO_RDR]
 363           | otherwise =
 364                 lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
 365                 returnRn (addOneFV fvs name')
 366         extra_fvs other = returnRn emptyFVs
 367     in
 368     checkRn (ok_ext_nm ext_nm) (badExtName ext_nm)      `thenRn_`
 369
 370     extra_fvs imp_exp                                   `thenRn` \ fvs1 ->
 371
 372     rnHsSigType fo_decl_msg ty                          `thenRn` \ (ty', fvs2) ->
 373     returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
 374               fvs1 `plusFV` fvs2)
 375  where
 376   fo_decl_msg = ptext SLIT("a foreign declaration")
 377   isDyn       = isDynamicExtName ext_nm
 378
 379   ok_ext_nm Dynamic                = True
 380   ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
 381   ok_ext_nm (ExtName nm Nothing)   = isCLabelString nm
 382 \end{code}
 383
 384 %*********************************************************
 385 %*                                                      *
 386 \subsection{Rules}
 387 %*                                                      *
 388 %*********************************************************
 389
 390 \begin{code}
 391 rnDecl (RuleD (IfaceRule rule_name vars fn args rhs src_loc))
 392   = pushSrcLocRn src_loc        $
 393     lookupOccRn fn              `thenRn` \ fn' ->
 394     rnCoreBndrs vars            $ \ vars' ->
 395     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs1) ->
 396     rnCoreExpr rhs              `thenRn` \ (rhs',  fvs2) ->
 397     returnRn (RuleD (IfaceRule rule_name vars' fn' args' rhs' src_loc),
 398               (fvs1 `plusFV` fvs2) `addOneFV` fn')
 399
 400 rnDecl (RuleD (IfaceRuleOut fn rule))
 401         -- This one is used for BuiltInRules
 402         -- The rule itself is already done, but the thing
 403         -- to attach it to is not.
 404   = lookupOccRn fn              `thenRn` \ fn' ->
 405     returnRn (RuleD (IfaceRuleOut fn' rule), unitFV fn')
 406
 407 rnDecl (RuleD (HsRule rule_name tvs vars lhs rhs src_loc))
 408   = ASSERT( null tvs )
 409     pushSrcLocRn src_loc                        $
 410
 411     bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
 412     bindLocalsFVRn doc (map get_var vars)       $ \ ids ->
 413     mapFvRn rn_var (vars `zip` ids)             `thenRn` \ (vars', fv_vars) ->
 414
 415     rnExpr lhs                                  `thenRn` \ (lhs', fv_lhs) ->
 416     rnExpr rhs                                  `thenRn` \ (rhs', fv_rhs) ->
 417     checkRn (validRuleLhs ids lhs')
 418             (badRuleLhsErr rule_name lhs')      `thenRn_`
 419     let
 420         bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
 421     in
 422     mapRn (addErrRn . badRuleVar rule_name) bad_vars    `thenRn_`
 423     returnRn (RuleD (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc),
 424               fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
 425   where
 426     doc = text "the transformation rule" <+> ptext rule_name
 427     sig_tvs = extractRuleBndrsTyVars vars
 428
 429     get_var (RuleBndr v)      = v
 430     get_var (RuleBndrSig v _) = v
 431
 432     rn_var (RuleBndr v, id)      = returnRn (RuleBndr id, emptyFVs)
 433     rn_var (RuleBndrSig v t, id) = rnHsType doc t       `thenRn` \ (t', fvs) ->
 434                                    returnRn (RuleBndrSig id t', fvs)
 435 \end{code}
 436
 437
 438 %*********************************************************
 439 %*                                                      *
 440 \subsection{Support code for type/data declarations}
 441 %*                                                      *
 442 %*********************************************************
 443
 444 \begin{code}
 445 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
 446
 447 rnDerivs Nothing -- derivs not specified
 448   = returnRn (Nothing, emptyFVs)
 449
 450 rnDerivs (Just clss)
 451   = mapRn do_one clss   `thenRn` \ clss' ->
 452     returnRn (Just clss', mkNameSet clss')
 453   where
 454     do_one cls = lookupOccRn cls        `thenRn` \ clas_name ->
 455                  checkRn (getUnique clas_name `elem` derivableClassKeys)
 456                          (derivingNonStdClassErr clas_name)     `thenRn_`
 457                  returnRn clas_name
 458 \end{code}
 459
 460 \begin{code}
 461 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 462 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
 463
 464 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
 465 rnConDecl (ConDecl name wkr tvs cxt details locn)
 466   = pushSrcLocRn locn $
 467     checkConName name           `thenRn_`
 468     lookupTopBndrRn name        `thenRn` \ new_name ->
 469
 470     lookupSysBinder wkr         `thenRn` \ new_wkr ->
 471         -- See comments with ClassDecl
 472
 473     bindTyVarsFVRn doc tvs              $ \ new_tyvars ->
 474     rnContext doc cxt                   `thenRn` \ (new_context, cxt_fvs) ->
 475     rnConDetails doc locn details       `thenRn` \ (new_details, det_fvs) ->
 476     returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn,
 477               cxt_fvs `plusFV` det_fvs)
 478   where
 479     doc = text "the definition of data constructor" <+> quotes (ppr name)
 480
 481 rnConDetails doc locn (VanillaCon tys)
 482   = mapFvRn (rnBangTy doc) tys  `thenRn` \ (new_tys, fvs)  ->
 483     returnRn (VanillaCon new_tys, fvs)
 484
 485 rnConDetails doc locn (InfixCon ty1 ty2)
 486   = rnBangTy doc ty1            `thenRn` \ (new_ty1, fvs1) ->
 487     rnBangTy doc ty2            `thenRn` \ (new_ty2, fvs2) ->
 488     returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
 489
 490 rnConDetails doc locn (RecCon fields)
 491   = checkDupOrQualNames doc field_names `thenRn_`
 492     mapFvRn (rnField doc) fields        `thenRn` \ (new_fields, fvs) ->
 493     returnRn (RecCon new_fields, fvs)
 494   where
 495     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 496
 497 rnField doc (names, ty)
 498   = mapRn lookupTopBndrRn names `thenRn` \ new_names ->
 499     rnBangTy doc ty             `thenRn` \ (new_ty, fvs) ->
 500     returnRn ((new_names, new_ty), fvs)
 501
 502 rnBangTy doc (Banged ty)
 503   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 504     returnRn (Banged new_ty, fvs)
 505
 506 rnBangTy doc (Unbanged ty)
 507   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 508     returnRn (Unbanged new_ty, fvs)
 509
 510 rnBangTy doc (Unpacked ty)
 511   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 512     returnRn (Unpacked new_ty, fvs)
 513
 514 -- This data decl will parse OK
 515 --      data T = a Int
 516 -- treating "a" as the constructor.
 517 -- It is really hard to make the parser spot this malformation.
 518 -- So the renamer has to check that the constructor is legal
 519 --
 520 -- We can get an operator as the constructor, even in the prefix form:
 521 --      data T = :% Int Int
 522 -- from interface files, which always print in prefix form
 523
 524 checkConName name
 525   = checkRn (isRdrDataCon name)
 526             (badDataCon name)
 527 \end{code}
 528
 529
 530 %*********************************************************
 531 %*                                                      *
 532 \subsection{Support code to rename types}
 533 %*                                                      *
 534 %*********************************************************
 535
 536 \begin{code}
 537 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 538         -- rnHsSigType is used for source-language type signatures,
 539         -- which use *implicit* universal quantification.
 540 rnHsSigType doc_str ty
 541   = rnHsType (text "the type signature for" <+> doc_str) ty
 542
 543 ---------------------------------------
 544 rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 545
 546 rnHsType doc (HsForAllTy Nothing ctxt ty)
 547         -- Implicit quantifiction in source code (no kinds on tyvars)
 548         -- Given the signature  C => T  we universally quantify
 549         -- over FV(T) \ {in-scope-tyvars}
 550   = getLocalNameEnv             `thenRn` \ name_env ->
 551     let
 552         mentioned_in_tau  = extractHsTyRdrTyVars ty
 553         mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
 554         mentioned         = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 555         forall_tyvars     = filter (not . (`elemFM` name_env)) mentioned
 556     in
 557     rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
 558
 559 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 560         -- Explicit quantification.
 561         -- Check that the forall'd tyvars are actually
 562         -- mentioned in the type, and produce a warning if not
 563   = let
 564         mentioned_in_tau                = extractHsTyRdrTyVars tau
 565         mentioned_in_ctxt               = extractHsCtxtRdrTyVars ctxt
 566         mentioned                       = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 567         forall_tyvar_names              = hsTyVarNames forall_tyvars
 568
 569         -- Explicitly quantified but not mentioned in ctxt or tau
 570         warn_guys                       = filter (`notElem` mentioned) forall_tyvar_names
 571     in
 572     mapRn_ (forAllWarn doc tau) warn_guys       `thenRn_`
 573     rnForAll doc forall_tyvars ctxt tau
 574
 575 rnHsType doc (HsTyVar tyvar)
 576   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 577     returnRn (HsTyVar tyvar', unitFV tyvar')
 578
 579 rnHsType doc (HsOpTy ty1 opname ty2)
 580   = lookupOccRn opname  `thenRn` \ name' ->
 581     rnHsType doc ty1    `thenRn` \ (ty1', fvs1) ->
 582     rnHsType doc ty2    `thenRn` \ (ty2',fvs2) ->
 583     returnRn (HsOpTy ty1' name' ty2', fvs1 `plusFV` fvs2 `addOneFV` name')
 584
 585 rnHsType doc (HsNumTy i)
 586   | i == 1    = returnRn (HsNumTy i, emptyFVs)
 587   | otherwise = failWithRn (HsNumTy i, emptyFVs)
 588                            (ptext SLIT("Only unit numeric type pattern is valid"))
 589
 590 rnHsType doc (HsFunTy ty1 ty2)
 591   = rnHsType doc ty1    `thenRn` \ (ty1', fvs1) ->
 592         -- Might find a for-all as the arg of a function type
 593     rnHsType doc ty2    `thenRn` \ (ty2', fvs2) ->
 594         -- Or as the result.  This happens when reading Prelude.hi
 595         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 596     returnRn (HsFunTy ty1' ty2', fvs1 `plusFV` fvs2)
 597
 598 rnHsType doc (HsListTy ty)
 599   = rnHsType doc ty                             `thenRn` \ (ty', fvs) ->
 600     returnRn (HsListTy ty', fvs `addOneFV` listTyCon_name)
 601
 602 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 603 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 604 rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
 605         -- Don't do lookupOccRn, because this is built-in syntax
 606         -- so it doesn't need to be in scope
 607   = mapFvRn (rnHsType doc) tys          `thenRn` \ (tys', fvs) ->
 608     returnRn (HsTupleTy (HsTupCon n' boxity) tys', fvs `addOneFV` n')
 609   where
 610     n' = tupleTyCon_name boxity (length tys)
 611
 612
 613 rnHsType doc (HsAppTy ty1 ty2)
 614   = rnHsType doc ty1            `thenRn` \ (ty1', fvs1) ->
 615     rnHsType doc ty2            `thenRn` \ (ty2', fvs2) ->
 616     returnRn (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2)
 617
 618 rnHsType doc (HsPredTy pred)
 619   = rnPred doc pred     `thenRn` \ (pred', fvs) ->
 620     returnRn (HsPredTy pred', fvs)
 621
 622 rnHsType doc (HsUsgForAllTy uv_rdr ty)
 623   = bindUVarRn doc uv_rdr $ \ uv_name ->
 624     rnHsType doc ty       `thenRn` \ (ty', fvs) ->
 625     returnRn (HsUsgForAllTy uv_name ty',
 626               fvs )
 627
 628 rnHsType doc (HsUsgTy usg ty)
 629   = newUsg usg                      `thenRn` \ (usg', usg_fvs) ->
 630     rnHsType doc ty                 `thenRn` \ (ty', ty_fvs) ->
 631         -- A for-all can occur inside a usage annotation
 632     returnRn (HsUsgTy usg' ty',
 633               usg_fvs `plusFV` ty_fvs)
 634   where
 635     newUsg usg = case usg of
 636                    HsUsOnce       -> returnRn (HsUsOnce, emptyFVs)
 637                    HsUsMany       -> returnRn (HsUsMany, emptyFVs)
 638                    HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
 639                                        returnRn (HsUsVar uv_name, emptyFVs)
 640
 641 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 642 \end{code}
 643
 644 \begin{code}
 645 -- We use lookupOcc here because this is interface file only stuff
 646 -- and we need the workers...
 647 rnHsTupCon (HsTupCon n boxity)
 648   = lookupOccRn n       `thenRn` \ n' ->
 649     returnRn (HsTupCon n' boxity, unitFV n')
 650
 651 rnHsTupConWkr (HsTupCon n boxity)
 652         -- Tuple construtors are for the *worker* of the tuple
 653         -- Going direct saves needless messing about
 654   = lookupOccRn (mkRdrNameWkr n)        `thenRn` \ n' ->
 655     returnRn (HsTupCon n' boxity, unitFV n')
 656 \end{code}
 657
 658 \begin{code}
 659 rnForAll doc forall_tyvars ctxt ty
 660   = bindTyVarsFVRn doc forall_tyvars    $ \ new_tyvars ->
 661     rnContext doc ctxt                  `thenRn` \ (new_ctxt, cxt_fvs) ->
 662     rnHsType doc ty                     `thenRn` \ (new_ty, ty_fvs) ->
 663     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
 664               cxt_fvs `plusFV` ty_fvs)
 665 \end{code}
 666
 667 \begin{code}
 668 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 669 rnContext doc ctxt
 670   = mapAndUnzipRn rn_pred ctxt          `thenRn` \ (theta, fvs_s) ->
 671     let
 672         (_, dups) = removeDupsEq theta
 673                 -- We only have equality, not ordering
 674     in
 675         -- Check for duplicate assertions
 676         -- If this isn't an error, then it ought to be:
 677     mapRn (addWarnRn . dupClassAssertWarn theta) dups           `thenRn_`
 678     returnRn (theta, plusFVs fvs_s)
 679   where
 680         --Someone discovered that @CCallable@ and @CReturnable@
 681         -- could be used in contexts such as:
 682         --      foo :: CCallable a => a -> PrimIO Int
 683         -- Doing this utterly wrecks the whole point of introducing these
 684         -- classes so we specifically check that this isn't being done.
 685     rn_pred pred = rnPred doc pred                              `thenRn` \ (pred', fvs)->
 686                    checkRn (not (bad_pred pred'))
 687                            (naughtyCCallContextErr pred')       `thenRn_`
 688                    returnRn (pred', fvs)
 689
 690     bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
 691     bad_pred other             = False
 692
 693
 694 rnPred doc (HsPClass clas tys)
 695   = lookupOccRn clas            `thenRn` \ clas_name ->
 696     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 697     returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
 698
 699 rnPred doc (HsPIParam n ty)
 700   = newIPName n                 `thenRn` \ name ->
 701     rnHsType doc ty             `thenRn` \ (ty', fvs) ->
 702     returnRn (HsPIParam name ty', fvs)
 703 \end{code}
 704
 705 \begin{code}
 706 rnFds :: SDoc -> [FunDep RdrName] -> RnMS ([FunDep Name], FreeVars)
 707
 708 rnFds doc fds
 709   = mapAndUnzipRn rn_fds fds            `thenRn` \ (theta, fvs_s) ->
 710     returnRn (theta, plusFVs fvs_s)
 711   where
 712     rn_fds (tys1, tys2)
 713       = rnHsTyVars doc tys1             `thenRn` \ (tys1', fvs1) ->
 714         rnHsTyVars doc tys2             `thenRn` \ (tys2', fvs2) ->
 715         returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
 716
 717 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
 718 rnHsTyvar doc tyvar
 719   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 720     returnRn (tyvar', unitFV tyvar')
 721 \end{code}
 722
 723 %*********************************************************
 724 %*                                                       *
 725 \subsection{IdInfo}
 726 %*                                                       *
 727 %*********************************************************
 728
 729 \begin{code}
 730 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
 731
 732 rnIdInfo (HsWorker worker)
 733   = lookupOccRn worker                  `thenRn` \ worker' ->
 734     returnRn (HsWorker worker', unitFV worker')
 735
 736 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
 737                                   returnRn (HsUnfold inline expr', fvs)
 738 rnIdInfo (HsArity arity)        = returnRn (HsArity arity, emptyFVs)
 739 rnIdInfo HsNoCafRefs            = returnRn (HsNoCafRefs, emptyFVs)
 740 rnIdInfo HsCprInfo              = returnRn (HsCprInfo, emptyFVs)
 741
 742 \end{code}
 743
 744 @UfCore@ expressions.
 745
 746 \begin{code}
 747 rnCoreExpr (UfType ty)
 748   = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
 749     returnRn (UfType ty', fvs)
 750
 751 rnCoreExpr (UfVar v)
 752   = lookupOccRn v       `thenRn` \ v' ->
 753     returnRn (UfVar v', unitFV v')
 754
 755 rnCoreExpr (UfLit l)
 756   = returnRn (UfLit l, emptyFVs)
 757
 758 rnCoreExpr (UfLitLit l ty)
 759   = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
 760     returnRn (UfLitLit l ty', fvs)
 761
 762 rnCoreExpr (UfCCall cc ty)
 763   = rnHsType (text "ccall") ty  `thenRn` \ (ty', fvs) ->
 764     returnRn (UfCCall cc ty', fvs)
 765
 766 rnCoreExpr (UfTuple con args)
 767   = rnHsTupConWkr con                   `thenRn` \ (con', fvs1) ->
 768     mapFvRn rnCoreExpr args             `thenRn` \ (args', fvs2) ->
 769     returnRn (UfTuple con' args', fvs1 `plusFV` fvs2)
 770
 771 rnCoreExpr (UfApp fun arg)
 772   = rnCoreExpr fun              `thenRn` \ (fun', fv1) ->
 773     rnCoreExpr arg              `thenRn` \ (arg', fv2) ->
 774     returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
 775
 776 rnCoreExpr (UfCase scrut bndr alts)
 777   = rnCoreExpr scrut                    `thenRn` \ (scrut', fvs1) ->
 778     bindCoreLocalFVRn bndr              ( \ bndr' ->
 779         mapFvRn rnCoreAlt alts          `thenRn` \ (alts', fvs2) ->
 780         returnRn (UfCase scrut' bndr' alts', fvs2)
 781     )                                           `thenRn` \ (case', fvs3) ->
 782     returnRn (case', fvs1 `plusFV` fvs3)
 783
 784 rnCoreExpr (UfNote note expr)
 785   = rnNote note                 `thenRn` \ (note', fvs1) ->
 786     rnCoreExpr expr             `thenRn` \ (expr', fvs2) ->
 787     returnRn  (UfNote note' expr', fvs1 `plusFV` fvs2)
 788
 789 rnCoreExpr (UfLam bndr body)
 790   = rnCoreBndr bndr             $ \ bndr' ->
 791     rnCoreExpr body             `thenRn` \ (body', fvs) ->
 792     returnRn (UfLam bndr' body', fvs)
 793
 794 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 795   = rnCoreExpr rhs              `thenRn` \ (rhs', fvs1) ->
 796     rnCoreBndr bndr             ( \ bndr' ->
 797         rnCoreExpr body         `thenRn` \ (body', fvs2) ->
 798         returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
 799     )                           `thenRn` \ (result, fvs3) ->
 800     returnRn (result, fvs1 `plusFV` fvs3)
 801
 802 rnCoreExpr (UfLet (UfRec pairs) body)
 803   = rnCoreBndrs bndrs           $ \ bndrs' ->
 804     mapFvRn rnCoreExpr rhss     `thenRn` \ (rhss', fvs1) ->
 805     rnCoreExpr body             `thenRn` \ (body', fvs2) ->
 806     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
 807   where
 808     (bndrs, rhss) = unzip pairs
 809 \end{code}
 810
 811 \begin{code}
 812 rnCoreBndr (UfValBinder name ty) thing_inside
 813   = rnHsType doc ty             `thenRn` \ (ty', fvs1) ->
 814     bindCoreLocalFVRn name      ( \ name' ->
 815             thing_inside (UfValBinder name' ty')
 816     )                           `thenRn` \ (result, fvs2) ->
 817     returnRn (result, fvs1 `plusFV` fvs2)
 818   where
 819     doc = text "unfolding id"
 820
 821 rnCoreBndr (UfTyBinder name kind) thing_inside
 822   = bindCoreLocalFVRn name              $ \ name' ->
 823     thing_inside (UfTyBinder name' kind)
 824
 825 rnCoreBndrs []     thing_inside = thing_inside []
 826 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 827                                   rnCoreBndrs bs        $ \ names' ->
 828                                   thing_inside (name':names')
 829 \end{code}
 830
 831 \begin{code}
 832 rnCoreAlt (con, bndrs, rhs)
 833   = rnUfCon con bndrs                   `thenRn` \ (con', fvs1) ->
 834     bindCoreLocalsFVRn bndrs            ( \ bndrs' ->
 835         rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
 836         returnRn ((con', bndrs', rhs'), fvs2)
 837     )                                   `thenRn` \ (result, fvs3) ->
 838     returnRn (result, fvs1 `plusFV` fvs3)
 839
 840 rnNote (UfCoerce ty)
 841   = rnHsType (text "unfolding coerce") ty       `thenRn` \ (ty', fvs) ->
 842     returnRn (UfCoerce ty', fvs)
 843
 844 rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
 845 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
 846 rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
 847
 848
 849 rnUfCon UfDefault _
 850   = returnRn (UfDefault, emptyFVs)
 851
 852 rnUfCon (UfTupleAlt tup_con) bndrs
 853   = rnHsTupCon tup_con          `thenRn` \ (HsTupCon con' _, fvs) ->
 854     returnRn (UfDataAlt con', fvs)
 855         -- Makes the type checker a little easier
 856
 857 rnUfCon (UfDataAlt con) _
 858   = lookupOccRn con             `thenRn` \ con' ->
 859     returnRn (UfDataAlt con', unitFV con')
 860
 861 rnUfCon (UfLitAlt lit) _
 862   = returnRn (UfLitAlt lit, emptyFVs)
 863
 864 rnUfCon (UfLitLitAlt lit ty) _
 865   = rnHsType (text "litlit") ty         `thenRn` \ (ty', fvs) ->
 866     returnRn (UfLitLitAlt lit ty', fvs)
 867 \end{code}
 868
 869 %*********************************************************
 870 %*                                                       *
 871 \subsection{Rule shapes}
 872 %*                                                       *
 873 %*********************************************************
 874
 875 Check the shape of a transformation rule LHS.  Currently
 876 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 877 not one of the @forall@'d variables.
 878
 879 \begin{code}
 880 validRuleLhs foralls lhs
 881   = check lhs
 882   where
 883     check (HsApp e1 e2)                   = check e1
 884     check (HsVar v) | v `notElem` foralls = True
 885     check other                           = False
 886 \end{code}
 887
 888
 889 %*********************************************************
 890 %*                                                       *
 891 \subsection{Errors}
 892 %*                                                       *
 893 %*********************************************************
 894
 895 \begin{code}
 896 derivingNonStdClassErr clas
 897   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 898
 899 classTyVarNotInOpTyErr clas_tyvar sig
 900   = hang (hsep [ptext SLIT("Class type variable"),
 901                        quotes (ppr clas_tyvar),
 902                        ptext SLIT("does not appear in method signature")])
 903          4 (ppr sig)
 904
 905 badDataCon name
 906    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 907
 908 forAllWarn doc ty tyvar
 909   = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of
 910     () | not warn_unused -> returnRn ()
 911        | otherwise
 912        -> getModeRn             `thenRn` \ mode ->
 913           case mode of {
 914 #ifndef DEBUG
 915              InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
 916                                             -- unless DEBUG is on, in which case it is slightly
 917                                             -- informative.  They can arise from mkRhsTyLam,
 918 #endif                                      -- leading to (say)         f :: forall a b. [b] -> [b]
 919              other ->
 920                 addWarnRn (
 921                    sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 922                    nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 923                    $$
 924                    (ptext SLIT("In") <+> doc)
 925                 )
 926           }
 927
 928 badRuleLhsErr name lhs
 929   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 930          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 931     $$
 932     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 933
 934 badRuleVar name var
 935   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 936          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 937                 ptext SLIT("does not appear on left hand side")]
 938
 939 badExtName :: ExtName -> Message
 940 badExtName ext_nm
 941   = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
 942
 943 dupClassAssertWarn ctxt (assertion : dups)
 944   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 945                quotes (ppr assertion),
 946                ptext SLIT("in the context:")],
 947          nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
 948
 949 naughtyCCallContextErr (HsPClass clas _)
 950   = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
 951          ptext SLIT("in a context")]
 952 \end{code}