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