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