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          ( getTyVarName, 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,
  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 = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
 303     in
 304         -- Rename the prags and signatures.
 305         -- Note that the type variables are not in scope here,
 306         -- so that      instance Eq a => Eq (T a) where
 307         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 308         -- works OK.
 309     renameSigs (okInstDclSig binders) uprags    `thenRn` \ (new_uprags, prag_fvs) ->
 310
 311     getModeRn           `thenRn` \ mode ->
 312     (case mode of
 313         InterfaceMode -> lookupImplicitOccRn dfun_rdr_name      `thenRn` \ dfun_name ->
 314                          returnRn (dfun_name, unitFV dfun_name)
 315         SourceMode    -> newDFunName (getDFunKey inst_ty') src_loc
 316                          `thenRn` \ dfun_name ->
 317                          returnRn (dfun_name, emptyFVs)
 318     )
 319     `thenRn` \ (dfun_name, dfun_fv) ->
 320
 321     -- The typechecker checks that all the bindings are for the right class.
 322     returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
 323               inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
 324   where
 325     meth_doc = text "the bindings in an instance declaration"
 326     meth_names   = bagToList (collectMonoBinders mbinds)
 327 \end{code}
 328
 329 %*********************************************************
 330 %*                                                      *
 331 \subsection{Default declarations}
 332 %*                                                      *
 333 %*********************************************************
 334
 335 \begin{code}
 336 rnDecl (DefD (DefaultDecl tys src_loc))
 337   = pushSrcLocRn src_loc $
 338     rnHsTypes doc_str tys               `thenRn` \ (tys', fvs) ->
 339     returnRn (DefD (DefaultDecl tys' src_loc), fvs)
 340   where
 341     doc_str = text "a `default' declaration"
 342 \end{code}
 343
 344 %*********************************************************
 345 %*                                                      *
 346 \subsection{Foreign declarations}
 347 %*                                                      *
 348 %*********************************************************
 349
 350 \begin{code}
 351 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
 352   = pushSrcLocRn src_loc $
 353     lookupOccRn name                    `thenRn` \ name' ->
 354     let
 355         extra_fvs FoExport
 356           | isDyn =
 357                 lookupImplicitOccsRn [makeStablePtr_RDR, deRefStablePtr_RDR,
 358                                       bindIO_RDR, returnIO_RDR]
 359           | otherwise =
 360                 lookupImplicitOccsRn [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
 361                 returnRn (addOneFV fvs name')
 362         extra_fvs other = returnRn emptyFVs
 363     in
 364     checkRn (ok_ext_nm ext_nm) (badExtName ext_nm)      `thenRn_`
 365
 366     extra_fvs imp_exp                                   `thenRn` \ fvs1 ->
 367
 368     rnHsSigType fo_decl_msg ty                          `thenRn` \ (ty', fvs2) ->
 369     returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
 370               fvs1 `plusFV` fvs2)
 371  where
 372   fo_decl_msg = ptext SLIT("a foreign declaration")
 373   isDyn       = isDynamicExtName ext_nm
 374
 375   ok_ext_nm Dynamic                = True
 376   ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
 377   ok_ext_nm (ExtName nm Nothing)   = isCLabelString nm
 378 \end{code}
 379
 380 %*********************************************************
 381 %*                                                      *
 382 \subsection{Rules}
 383 %*                                                      *
 384 %*********************************************************
 385
 386 \begin{code}
 387 rnDecl (RuleD (IfaceRule rule_name vars fn args rhs src_loc))
 388   = pushSrcLocRn src_loc        $
 389     lookupOccRn fn              `thenRn` \ fn' ->
 390     rnCoreBndrs vars            $ \ vars' ->
 391     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs1) ->
 392     rnCoreExpr rhs              `thenRn` \ (rhs',  fvs2) ->
 393     returnRn (RuleD (IfaceRule rule_name vars' fn' args' rhs' src_loc),
 394               (fvs1 `plusFV` fvs2) `addOneFV` fn')
 395
 396 rnDecl (RuleD (IfaceRuleOut fn rule))
 397         -- This one is used for BuiltInRules
 398         -- The rule itself is already done, but the thing
 399         -- to attach it to is not.
 400   = lookupOccRn fn              `thenRn` \ fn' ->
 401     returnRn (RuleD (IfaceRuleOut fn' rule), unitFV fn')
 402
 403 rnDecl (RuleD (HsRule rule_name tvs vars lhs rhs src_loc))
 404   = ASSERT( null tvs )
 405     pushSrcLocRn src_loc                        $
 406
 407     bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
 408     bindLocalsFVRn doc (map get_var vars)       $ \ ids ->
 409     mapFvRn rn_var (vars `zip` ids)             `thenRn` \ (vars', fv_vars) ->
 410
 411     rnExpr lhs                                  `thenRn` \ (lhs', fv_lhs) ->
 412     rnExpr rhs                                  `thenRn` \ (rhs', fv_rhs) ->
 413     checkRn (validRuleLhs ids lhs')
 414             (badRuleLhsErr rule_name lhs')      `thenRn_`
 415     let
 416         bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
 417     in
 418     mapRn (addErrRn . badRuleVar rule_name) bad_vars    `thenRn_`
 419     returnRn (RuleD (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc),
 420               fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
 421   where
 422     doc = text "the transformation rule" <+> ptext rule_name
 423     sig_tvs = extractRuleBndrsTyVars vars
 424
 425     get_var (RuleBndr v)      = v
 426     get_var (RuleBndrSig v _) = v
 427
 428     rn_var (RuleBndr v, id)      = returnRn (RuleBndr id, emptyFVs)
 429     rn_var (RuleBndrSig v t, id) = rnHsType doc t       `thenRn` \ (t', fvs) ->
 430                                    returnRn (RuleBndrSig id t', fvs)
 431 \end{code}
 432
 433
 434 %*********************************************************
 435 %*                                                      *
 436 \subsection{Support code for type/data declarations}
 437 %*                                                      *
 438 %*********************************************************
 439
 440 \begin{code}
 441 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
 442
 443 rnDerivs Nothing -- derivs not specified
 444   = returnRn (Nothing, emptyFVs)
 445
 446 rnDerivs (Just clss)
 447   = mapRn do_one clss   `thenRn` \ clss' ->
 448     returnRn (Just clss', mkNameSet clss')
 449   where
 450     do_one cls = lookupOccRn cls        `thenRn` \ clas_name ->
 451                  checkRn (getUnique clas_name `elem` derivableClassKeys)
 452                          (derivingNonStdClassErr clas_name)     `thenRn_`
 453                  returnRn clas_name
 454 \end{code}
 455
 456 \begin{code}
 457 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 458 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
 459
 460 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
 461 rnConDecl (ConDecl name wkr tvs cxt details locn)
 462   = pushSrcLocRn locn $
 463     checkConName name                   `thenRn_`
 464     lookupBndrRn name                   `thenRn` \ new_name ->
 465
 466     mkImportedGlobalFromRdrName wkr     `thenRn` \ new_wkr ->
 467         -- See comments with ClassDecl
 468
 469     bindTyVarsFVRn doc tvs              $ \ new_tyvars ->
 470     rnContext doc cxt                   `thenRn` \ (new_context, cxt_fvs) ->
 471     rnConDetails doc locn details       `thenRn` \ (new_details, det_fvs) ->
 472     returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn,
 473               cxt_fvs `plusFV` det_fvs)
 474   where
 475     doc = text "the definition of data constructor" <+> quotes (ppr name)
 476
 477 rnConDetails doc locn (VanillaCon tys)
 478   = mapFvRn (rnBangTy doc) tys  `thenRn` \ (new_tys, fvs)  ->
 479     returnRn (VanillaCon new_tys, fvs)
 480
 481 rnConDetails doc locn (InfixCon ty1 ty2)
 482   = rnBangTy doc ty1            `thenRn` \ (new_ty1, fvs1) ->
 483     rnBangTy doc ty2            `thenRn` \ (new_ty2, fvs2) ->
 484     returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
 485
 486 rnConDetails doc locn (NewCon ty mb_field)
 487   = rnHsType doc ty                     `thenRn` \ (new_ty, fvs) ->
 488     rn_field mb_field                   `thenRn` \ new_mb_field  ->
 489     returnRn (NewCon new_ty new_mb_field, fvs)
 490   where
 491     rn_field Nothing  = returnRn Nothing
 492     rn_field (Just f) =
 493        lookupBndrRn f       `thenRn` \ new_f ->
 494        returnRn (Just new_f)
 495
 496 rnConDetails doc locn (RecCon fields)
 497   = checkDupOrQualNames doc field_names `thenRn_`
 498     mapFvRn (rnField doc) fields        `thenRn` \ (new_fields, fvs) ->
 499     returnRn (RecCon new_fields, fvs)
 500   where
 501     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 502
 503 rnField doc (names, ty)
 504   = mapRn lookupBndrRn names    `thenRn` \ new_names ->
 505     rnBangTy doc ty             `thenRn` \ (new_ty, fvs) ->
 506     returnRn ((new_names, new_ty), fvs)
 507
 508 rnBangTy doc (Banged ty)
 509   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 510     returnRn (Banged new_ty, fvs)
 511
 512 rnBangTy doc (Unbanged ty)
 513   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 514     returnRn (Unbanged new_ty, fvs)
 515
 516 rnBangTy doc (Unpacked ty)
 517   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 518     returnRn (Unpacked new_ty, fvs)
 519
 520 -- This data decl will parse OK
 521 --      data T = a Int
 522 -- treating "a" as the constructor.
 523 -- It is really hard to make the parser spot this malformation.
 524 -- So the renamer has to check that the constructor is legal
 525 --
 526 -- We can get an operator as the constructor, even in the prefix form:
 527 --      data T = :% Int Int
 528 -- from interface files, which always print in prefix form
 529
 530 checkConName name
 531   = checkRn (isRdrDataCon name)
 532             (badDataCon name)
 533 \end{code}
 534
 535
 536 %*********************************************************
 537 %*                                                      *
 538 \subsection{Support code to rename types}
 539 %*                                                      *
 540 %*********************************************************
 541
 542 \begin{code}
 543 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 544         -- rnHsSigType is used for source-language type signatures,
 545         -- which use *implicit* universal quantification.
 546 rnHsSigType doc_str ty
 547   = rnHsType (text "the type signature for" <+> doc_str) ty
 548
 549 ---------------------------------------
 550 rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 551
 552 rnHsType doc (HsForAllTy Nothing ctxt ty)
 553         -- Implicit quantifiction in source code (no kinds on tyvars)
 554         -- Given the signature  C => T  we universally quantify
 555         -- over FV(T) \ {in-scope-tyvars}
 556   = getLocalNameEnv             `thenRn` \ name_env ->
 557     let
 558         mentioned_in_tau  = extractHsTyRdrTyVars ty
 559         mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
 560         mentioned         = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 561         forall_tyvars     = filter (not . (`elemFM` name_env)) mentioned
 562     in
 563     rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
 564
 565 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 566         -- Explicit quantification.
 567         -- Check that the forall'd tyvars are actually
 568         -- mentioned in the type, and produce a warning if not
 569   = let
 570         mentioned_in_tau                = extractHsTyRdrTyVars tau
 571         mentioned_in_ctxt               = extractHsCtxtRdrTyVars ctxt
 572         mentioned                       = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 573         forall_tyvar_names              = map getTyVarName forall_tyvars
 574
 575         -- Explicitly quantified but not mentioned in ctxt or tau
 576         warn_guys                       = filter (`notElem` mentioned) forall_tyvar_names
 577     in
 578     mapRn_ (forAllWarn doc tau) warn_guys                       `thenRn_`
 579     rnForAll doc forall_tyvars ctxt tau
 580
 581 rnHsType doc (HsTyVar tyvar)
 582   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 583     returnRn (HsTyVar tyvar', unitFV tyvar')
 584
 585 rnHsType doc (HsFunTy ty1 ty2)
 586   = rnHsType doc ty1    `thenRn` \ (ty1', fvs1) ->
 587         -- Might find a for-all as the arg of a function type
 588     rnHsType doc ty2    `thenRn` \ (ty2', fvs2) ->
 589         -- Or as the result.  This happens when reading Prelude.hi
 590         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 591     returnRn (HsFunTy ty1' ty2', fvs1 `plusFV` fvs2)
 592
 593 rnHsType doc (HsListTy ty)
 594   = rnHsType doc ty                             `thenRn` \ (ty', fvs) ->
 595     returnRn (HsListTy ty', fvs `addOneFV` listTyCon_name)
 596
 597 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 598 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 599 rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
 600         -- Don't do lookupOccRn, because this is built-in syntax
 601         -- so it doesn't need to be in scope
 602   = mapFvRn (rnHsType doc) tys          `thenRn` \ (tys', fvs) ->
 603     returnRn (HsTupleTy (HsTupCon n' boxity) tys', fvs `addOneFV` n')
 604   where
 605     n' = tupleTyCon_name boxity (length tys)
 606
 607
 608 rnHsType doc (HsAppTy ty1 ty2)
 609   = rnHsType doc ty1            `thenRn` \ (ty1', fvs1) ->
 610     rnHsType doc ty2            `thenRn` \ (ty2', fvs2) ->
 611     returnRn (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2)
 612
 613 rnHsType doc (HsPredTy pred)
 614   = rnPred doc pred     `thenRn` \ (pred', fvs) ->
 615     returnRn (HsPredTy pred', fvs)
 616
 617 rnHsType doc (HsUsgForAllTy uv_rdr ty)
 618   = bindUVarRn doc uv_rdr $ \ uv_name ->
 619     rnHsType doc ty       `thenRn` \ (ty', fvs) ->
 620     returnRn (HsUsgForAllTy uv_name ty',
 621               fvs )
 622
 623 rnHsType doc (HsUsgTy usg ty)
 624   = newUsg usg                      `thenRn` \ (usg', usg_fvs) ->
 625     rnHsType doc ty                 `thenRn` \ (ty', ty_fvs) ->
 626         -- A for-all can occur inside a usage annotation
 627     returnRn (HsUsgTy usg' ty',
 628               usg_fvs `plusFV` ty_fvs)
 629   where
 630     newUsg usg = case usg of
 631                    HsUsOnce       -> returnRn (HsUsOnce, emptyFVs)
 632                    HsUsMany       -> returnRn (HsUsMany, emptyFVs)
 633                    HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
 634                                        returnRn (HsUsVar uv_name, emptyFVs)
 635
 636 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 637 \end{code}
 638
 639 \begin{code}
 640 -- We use lookupOcc here because this is interface file only stuff
 641 -- and we need the workers...
 642 rnHsTupCon (HsTupCon n boxity)
 643   = lookupOccRn n       `thenRn` \ n' ->
 644     returnRn (HsTupCon n' boxity, unitFV n')
 645
 646 rnHsTupConWkr (HsTupCon n boxity)
 647         -- Tuple construtors are for the *worker* of the tuple
 648         -- Going direct saves needless messing about
 649   = lookupOccRn (mkRdrNameWkr n)        `thenRn` \ n' ->
 650     returnRn (HsTupCon n' boxity, unitFV n')
 651 \end{code}
 652
 653 \begin{code}
 654 -- Check that each constraint mentions at least one of the forall'd type variables
 655 -- Since the forall'd type variables are a subset of the free tyvars
 656 -- of the tau-type part, this guarantees that every constraint mentions
 657 -- at least one of the free tyvars in ty
 658 checkConstraints doc forall_tyvars tau_vars ctxt ty
 659    = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->
 660      returnRn (catMaybes maybe_ctxt')
 661             -- Remove problem ones, to avoid duplicate error message.
 662
 663 checkPred doc forall_tyvars ty p@(HsPClass clas tys)
 664   | not_univ  = failWithRn Nothing (univErr  doc p ty)
 665   | otherwise = returnRn (Just p)
 666   where
 667       ct_vars  = extractHsTysRdrTyVars tys
 668       not_univ =  -- At least one of the tyvars in each constraint must
 669                   -- be universally quantified. This restriction isn't in Hugs
 670                   not (any (`elem` forall_tyvars) ct_vars)
 671 checkPred doc forall_tyvars ty p@(HsPIParam _ _)
 672   = returnRn (Just p)
 673
 674 rnForAll doc forall_tyvars ctxt ty
 675   = bindTyVarsFVRn doc forall_tyvars    $ \ new_tyvars ->
 676     rnContext doc ctxt                  `thenRn` \ (new_ctxt, cxt_fvs) ->
 677     rnHsType doc ty                     `thenRn` \ (new_ty, ty_fvs) ->
 678     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
 679               cxt_fvs `plusFV` ty_fvs)
 680 \end{code}
 681
 682 \begin{code}
 683 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 684 rnContext doc ctxt
 685   = mapAndUnzipRn rn_pred ctxt          `thenRn` \ (theta, fvs_s) ->
 686     let
 687         (_, dups) = removeDupsEq theta
 688                 -- We only have equality, not ordering
 689     in
 690         -- Check for duplicate assertions
 691         -- If this isn't an error, then it ought to be:
 692     mapRn (addWarnRn . dupClassAssertWarn theta) dups           `thenRn_`
 693     returnRn (theta, plusFVs fvs_s)
 694   where
 695         --Someone discovered that @CCallable@ and @CReturnable@
 696         -- could be used in contexts such as:
 697         --      foo :: CCallable a => a -> PrimIO Int
 698         -- Doing this utterly wrecks the whole point of introducing these
 699         -- classes so we specifically check that this isn't being done.
 700     rn_pred pred = rnPred doc pred                              `thenRn` \ (pred', fvs)->
 701                    checkRn (not (bad_pred pred'))
 702                            (naughtyCCallContextErr pred')       `thenRn_`
 703                    returnRn (pred', fvs)
 704
 705     bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
 706     bad_pred other             = False
 707
 708
 709 rnPred doc (HsPClass clas tys)
 710   = lookupOccRn clas            `thenRn` \ clas_name ->
 711     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 712     returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
 713
 714 rnPred doc (HsPIParam n ty)
 715   = getIPName n                 `thenRn` \ name ->
 716     rnHsType doc ty             `thenRn` \ (ty', fvs) ->
 717     returnRn (HsPIParam name ty', fvs)
 718 \end{code}
 719
 720 \begin{code}
 721 rnFds :: SDoc -> [FunDep RdrName] -> RnMS ([FunDep Name], FreeVars)
 722
 723 rnFds doc fds
 724   = mapAndUnzipRn rn_fds fds            `thenRn` \ (theta, fvs_s) ->
 725     returnRn (theta, plusFVs fvs_s)
 726   where
 727     rn_fds (tys1, tys2)
 728       = rnHsTyVars doc tys1             `thenRn` \ (tys1', fvs1) ->
 729         rnHsTyVars doc tys2             `thenRn` \ (tys2', fvs2) ->
 730         returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
 731
 732 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
 733 rnHsTyvar doc tyvar
 734   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 735     returnRn (tyvar', unitFV tyvar')
 736 \end{code}
 737
 738 %*********************************************************
 739 %*                                                       *
 740 \subsection{IdInfo}
 741 %*                                                       *
 742 %*********************************************************
 743
 744 \begin{code}
 745 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
 746
 747 rnIdInfo (HsWorker worker)
 748   = lookupOccRn worker                  `thenRn` \ worker' ->
 749     returnRn (HsWorker worker', unitFV worker')
 750
 751 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
 752                                   returnRn (HsUnfold inline expr', fvs)
 753 rnIdInfo (HsArity arity)        = returnRn (HsArity arity, emptyFVs)
 754 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update, emptyFVs)
 755 rnIdInfo HsNoCafRefs            = returnRn (HsNoCafRefs, emptyFVs)
 756 rnIdInfo HsCprInfo              = returnRn (HsCprInfo, emptyFVs)
 757
 758 \end{code}
 759
 760 @UfCore@ expressions.
 761
 762 \begin{code}
 763 rnCoreExpr (UfType ty)
 764   = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
 765     returnRn (UfType ty', fvs)
 766
 767 rnCoreExpr (UfVar v)
 768   = lookupOccRn v       `thenRn` \ v' ->
 769     returnRn (UfVar v', unitFV v')
 770
 771 rnCoreExpr (UfLit l)
 772   = returnRn (UfLit l, emptyFVs)
 773
 774 rnCoreExpr (UfLitLit l ty)
 775   = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
 776     returnRn (UfLitLit l ty', fvs)
 777
 778 rnCoreExpr (UfCCall cc ty)
 779   = rnHsType (text "ccall") ty  `thenRn` \ (ty', fvs) ->
 780     returnRn (UfCCall cc ty', fvs)
 781
 782 rnCoreExpr (UfTuple con args)
 783   = rnHsTupConWkr con                   `thenRn` \ (con', fvs1) ->
 784     mapFvRn rnCoreExpr args             `thenRn` \ (args', fvs2) ->
 785     returnRn (UfTuple con' args', fvs1 `plusFV` fvs2)
 786
 787 rnCoreExpr (UfApp fun arg)
 788   = rnCoreExpr fun              `thenRn` \ (fun', fv1) ->
 789     rnCoreExpr arg              `thenRn` \ (arg', fv2) ->
 790     returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
 791
 792 rnCoreExpr (UfCase scrut bndr alts)
 793   = rnCoreExpr scrut                    `thenRn` \ (scrut', fvs1) ->
 794     bindCoreLocalFVRn bndr              ( \ bndr' ->
 795         mapFvRn rnCoreAlt alts          `thenRn` \ (alts', fvs2) ->
 796         returnRn (UfCase scrut' bndr' alts', fvs2)
 797     )                                           `thenRn` \ (case', fvs3) ->
 798     returnRn (case', fvs1 `plusFV` fvs3)
 799
 800 rnCoreExpr (UfNote note expr)
 801   = rnNote note                 `thenRn` \ (note', fvs1) ->
 802     rnCoreExpr expr             `thenRn` \ (expr', fvs2) ->
 803     returnRn  (UfNote note' expr', fvs1 `plusFV` fvs2)
 804
 805 rnCoreExpr (UfLam bndr body)
 806   = rnCoreBndr bndr             $ \ bndr' ->
 807     rnCoreExpr body             `thenRn` \ (body', fvs) ->
 808     returnRn (UfLam bndr' body', fvs)
 809
 810 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 811   = rnCoreExpr rhs              `thenRn` \ (rhs', fvs1) ->
 812     rnCoreBndr bndr             ( \ bndr' ->
 813         rnCoreExpr body         `thenRn` \ (body', fvs2) ->
 814         returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
 815     )                           `thenRn` \ (result, fvs3) ->
 816     returnRn (result, fvs1 `plusFV` fvs3)
 817
 818 rnCoreExpr (UfLet (UfRec pairs) body)
 819   = rnCoreBndrs bndrs           $ \ bndrs' ->
 820     mapFvRn rnCoreExpr rhss     `thenRn` \ (rhss', fvs1) ->
 821     rnCoreExpr body             `thenRn` \ (body', fvs2) ->
 822     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
 823   where
 824     (bndrs, rhss) = unzip pairs
 825 \end{code}
 826
 827 \begin{code}
 828 rnCoreBndr (UfValBinder name ty) thing_inside
 829   = rnHsType doc ty             `thenRn` \ (ty', fvs1) ->
 830     bindCoreLocalFVRn name      ( \ name' ->
 831             thing_inside (UfValBinder name' ty')
 832     )                           `thenRn` \ (result, fvs2) ->
 833     returnRn (result, fvs1 `plusFV` fvs2)
 834   where
 835     doc = text "unfolding id"
 836
 837 rnCoreBndr (UfTyBinder name kind) thing_inside
 838   = bindCoreLocalFVRn name              $ \ name' ->
 839     thing_inside (UfTyBinder name' kind)
 840
 841 rnCoreBndrs []     thing_inside = thing_inside []
 842 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 843                                   rnCoreBndrs bs        $ \ names' ->
 844                                   thing_inside (name':names')
 845 \end{code}
 846
 847 \begin{code}
 848 rnCoreAlt (con, bndrs, rhs)
 849   = rnUfCon con bndrs                   `thenRn` \ (con', fvs1) ->
 850     bindCoreLocalsFVRn bndrs            ( \ bndrs' ->
 851         rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
 852         returnRn ((con', bndrs', rhs'), fvs2)
 853     )                                   `thenRn` \ (result, fvs3) ->
 854     returnRn (result, fvs1 `plusFV` fvs3)
 855
 856 rnNote (UfCoerce ty)
 857   = rnHsType (text "unfolding coerce") ty       `thenRn` \ (ty', fvs) ->
 858     returnRn (UfCoerce ty', fvs)
 859
 860 rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
 861 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
 862 rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
 863
 864
 865 rnUfCon UfDefault _
 866   = returnRn (UfDefault, emptyFVs)
 867
 868 rnUfCon (UfTupleAlt tup_con) bndrs
 869   = rnHsTupCon tup_con          `thenRn` \ (HsTupCon con' _, fvs) ->
 870     returnRn (UfDataAlt con', fvs)
 871         -- Makes the type checker a little easier
 872
 873 rnUfCon (UfDataAlt con) _
 874   = lookupOccRn con             `thenRn` \ con' ->
 875     returnRn (UfDataAlt con', unitFV con')
 876
 877 rnUfCon (UfLitAlt lit) _
 878   = returnRn (UfLitAlt lit, emptyFVs)
 879
 880 rnUfCon (UfLitLitAlt lit ty) _
 881   = rnHsType (text "litlit") ty         `thenRn` \ (ty', fvs) ->
 882     returnRn (UfLitLitAlt lit ty', fvs)
 883 \end{code}
 884
 885 %*********************************************************
 886 %*                                                       *
 887 \subsection{Rule shapes}
 888 %*                                                       *
 889 %*********************************************************
 890
 891 Check the shape of a transformation rule LHS.  Currently
 892 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 893 not one of the @forall@'d variables.
 894
 895 \begin{code}
 896 validRuleLhs foralls lhs
 897   = check lhs
 898   where
 899     check (HsApp e1 e2)                   = check e1
 900     check (HsVar v) | v `notElem` foralls = True
 901     check other                           = False
 902 \end{code}
 903
 904
 905 %*********************************************************
 906 %*                                                       *
 907 \subsection{Errors}
 908 %*                                                       *
 909 %*********************************************************
 910
 911 \begin{code}
 912 derivingNonStdClassErr clas
 913   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 914
 915 classTyVarNotInOpTyErr clas_tyvar sig
 916   = hang (hsep [ptext SLIT("Class type variable"),
 917                        quotes (ppr clas_tyvar),
 918                        ptext SLIT("does not appear in method signature")])
 919          4 (ppr sig)
 920
 921 badDataCon name
 922    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 923
 924 forAllWarn doc ty tyvar
 925   | not opt_WarnUnusedMatches = returnRn ()
 926   | otherwise
 927   = getModeRn           `thenRn` \ mode ->
 928     case mode of {
 929 #ifndef DEBUG
 930         InterfaceMode -> returnRn () ;  -- Don't warn of unused tyvars in interface files
 931                                         -- unless DEBUG is on, in which case it is slightly
 932                                         -- informative.  They can arise from mkRhsTyLam,
 933 #endif                                  -- leading to (say)     f :: forall a b. [b] -> [b]
 934         other ->
 935
 936     addWarnRn (
 937       sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 938            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 939       $$
 940       (ptext SLIT("In") <+> doc))
 941     }
 942
 943 forAllErr doc ty tyvar
 944   = addErrRn (
 945       sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
 946            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 947       $$
 948       (ptext SLIT("In") <+> doc))
 949
 950 univErr doc constraint ty
 951   = sep [ptext SLIT("All of the type variable(s) in the constraint")
 952           <+> quotes (ppr constraint)
 953           <+> ptext SLIT("are already in scope"),
 954          nest 4 (ptext SLIT("At least one must be universally quantified here"))
 955     ]
 956     $$
 957     (ptext SLIT("In") <+> doc)
 958
 959 badRuleLhsErr name lhs
 960   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 961          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 962     $$
 963     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 964
 965 badRuleVar name var
 966   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 967          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 968                 ptext SLIT("does not appear on left hand side")]
 969
 970 badExtName :: ExtName -> Message
 971 badExtName ext_nm
 972   = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
 973
 974 dupClassAssertWarn ctxt (assertion : dups)
 975   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 976                quotes (ppr assertion),
 977                ptext SLIT("in the context:")],
 978          nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
 979
 980 naughtyCCallContextErr (HsPClass clas _)
 981   = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
 982          ptext SLIT("in a context")]
 983 \end{code}