ghc/compiler/rename/RnSource.lhs

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