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