ghc/compiler/rename/RnSource.lhs

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