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