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