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