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