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 (BangType s ty)
 492   = rnHsType doc ty             `thenRn` \ new_ty ->
 493     returnRn (BangType s new_ty)
 494
 495 -- This data decl will parse OK
 496 --      data T = a Int
 497 -- treating "a" as the constructor.
 498 -- It is really hard to make the parser spot this malformation.
 499 -- So the renamer has to check that the constructor is legal
 500 --
 501 -- We can get an operator as the constructor, even in the prefix form:
 502 --      data T = :% Int Int
 503 -- from interface files, which always print in prefix form
 504
 505 checkConName name
 506   = checkRn (isRdrDataCon name)
 507             (badDataCon name)
 508 \end{code}
 509
 510
 511 %*********************************************************
 512 %*                                                      *
 513 \subsection{Support code to rename types}
 514 %*                                                      *
 515 %*********************************************************
 516
 517 \begin{code}
 518 rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 519 rnHsTypeFVs doc_str ty
 520   = rnHsType doc_str ty         `thenRn` \ ty' ->
 521     returnRn (ty', extractHsTyNames ty')
 522
 523 rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 524 rnHsSigTypeFVs doc_str ty
 525   = rnHsSigType doc_str ty      `thenRn` \ ty' ->
 526     returnRn (ty', extractHsTyNames ty')
 527
 528 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
 529         -- rnHsSigType is used for source-language type signatures,
 530         -- which use *implicit* universal quantification.
 531 rnHsSigType doc_str ty
 532   = rnHsType (text "the type signature for" <+> doc_str) ty
 533
 534 ---------------------------------------
 535 rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
 536
 537 rnHsType doc (HsForAllTy Nothing ctxt ty)
 538         -- Implicit quantifiction in source code (no kinds on tyvars)
 539         -- Given the signature  C => T  we universally quantify
 540         -- over FV(T) \ {in-scope-tyvars}
 541   = getLocalNameEnv             `thenRn` \ name_env ->
 542     let
 543         mentioned_in_tau  = extractHsTyRdrTyVars ty
 544         mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
 545         mentioned         = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 546         forall_tyvars     = filter (not . (`elemRdrEnv` name_env)) mentioned
 547     in
 548     rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
 549
 550 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 551         -- Explicit quantification.
 552         -- Check that the forall'd tyvars are actually
 553         -- mentioned in the type, and produce a warning if not
 554   = let
 555         mentioned_in_tau                = extractHsTyRdrTyVars tau
 556         mentioned_in_ctxt               = extractHsCtxtRdrTyVars ctxt
 557         mentioned                       = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 558         forall_tyvar_names              = hsTyVarNames forall_tyvars
 559
 560         -- Explicitly quantified but not mentioned in ctxt or tau
 561         warn_guys                       = filter (`notElem` mentioned) forall_tyvar_names
 562     in
 563     mapRn_ (forAllWarn doc tau) warn_guys       `thenRn_`
 564     rnForAll doc forall_tyvars ctxt tau
 565
 566 rnHsType doc (HsTyVar tyvar)
 567   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 568     returnRn (HsTyVar tyvar')
 569
 570 rnHsType doc (HsOpTy ty1 opname ty2)
 571   = lookupOccRn opname  `thenRn` \ name' ->
 572     rnHsType doc ty1    `thenRn` \ ty1' ->
 573     rnHsType doc ty2    `thenRn` \ ty2' ->
 574     returnRn (HsOpTy ty1' name' ty2')
 575
 576 rnHsType doc (HsNumTy i)
 577   | i == 1    = returnRn (HsNumTy i)
 578   | otherwise = failWithRn (HsNumTy i)
 579                            (ptext SLIT("Only unit numeric type pattern is valid"))
 580
 581 rnHsType doc (HsFunTy ty1 ty2)
 582   = rnHsType doc ty1    `thenRn` \ ty1' ->
 583         -- Might find a for-all as the arg of a function type
 584     rnHsType doc ty2    `thenRn` \ ty2' ->
 585         -- Or as the result.  This happens when reading Prelude.hi
 586         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 587     returnRn (HsFunTy ty1' ty2')
 588
 589 rnHsType doc (HsListTy ty)
 590   = rnHsType doc ty                             `thenRn` \ ty' ->
 591     returnRn (HsListTy ty')
 592
 593 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 594 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 595 rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys)
 596         -- Don't do lookupOccRn, because this is built-in syntax
 597         -- so it doesn't need to be in scope
 598   = mapRn (rnHsType doc) tys            `thenRn` \ tys' ->
 599     returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys')
 600   where
 601     tup_name = tupleTyCon_name boxity arity
 602
 603
 604 rnHsType doc (HsAppTy ty1 ty2)
 605   = rnHsType doc ty1            `thenRn` \ ty1' ->
 606     rnHsType doc ty2            `thenRn` \ ty2' ->
 607     returnRn (HsAppTy ty1' ty2')
 608
 609 rnHsType doc (HsPredTy pred)
 610   = rnPred doc pred     `thenRn` \ pred' ->
 611     returnRn (HsPredTy pred')
 612
 613 rnHsTypes doc tys = mapRn (rnHsType doc) tys
 614 \end{code}
 615
 616 \begin{code}
 617 rnForAll doc forall_tyvars ctxt ty
 618   = bindTyVarsRn doc forall_tyvars      $ \ new_tyvars ->
 619     rnContext doc ctxt                  `thenRn` \ new_ctxt ->
 620     rnHsType doc ty                     `thenRn` \ new_ty ->
 621     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
 622 \end{code}
 623
 624 \begin{code}
 625 rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext
 626 rnContext doc ctxt
 627   = mapRn rn_pred ctxt          `thenRn` \ theta ->
 628
 629         -- Check for duplicate assertions
 630         -- If this isn't an error, then it ought to be:
 631     ifOptRn Opt_WarnMisc (
 632         let
 633             (_, dups) = removeDupsEq theta
 634                 -- We only have equality, not ordering
 635         in
 636         mapRn (addWarnRn . dupClassAssertWarn theta) dups
 637     )                           `thenRn_`
 638
 639     returnRn theta
 640   where
 641         --Someone discovered that @CCallable@ and @CReturnable@
 642         -- could be used in contexts such as:
 643         --      foo :: CCallable a => a -> PrimIO Int
 644         -- Doing this utterly wrecks the whole point of introducing these
 645         -- classes so we specifically check that this isn't being done.
 646     rn_pred pred = rnPred doc pred                              `thenRn` \ pred'->
 647                    checkRn (not (bad_pred pred'))
 648                            (naughtyCCallContextErr pred')       `thenRn_`
 649                    returnRn pred'
 650
 651     bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys
 652     bad_pred other             = False
 653
 654
 655 rnPred doc (HsClassP clas tys)
 656   = lookupOccRn clas            `thenRn` \ clas_name ->
 657     rnHsTypes doc tys           `thenRn` \ tys' ->
 658     returnRn (HsClassP clas_name tys')
 659
 660 rnPred doc (HsIParam n ty)
 661   = newIPName n                 `thenRn` \ name ->
 662     rnHsType doc ty             `thenRn` \ ty' ->
 663     returnRn (HsIParam name ty')
 664 \end{code}
 665
 666 \begin{code}
 667 rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name]
 668
 669 rnFds doc fds
 670   = mapRn rn_fds fds
 671   where
 672     rn_fds (tys1, tys2)
 673       = rnHsTyVars doc tys1             `thenRn` \ tys1' ->
 674         rnHsTyVars doc tys2             `thenRn` \ tys2' ->
 675         returnRn (tys1', tys2')
 676
 677 rnHsTyVars doc tvs  = mapRn (rnHsTyvar doc) tvs
 678 rnHsTyvar doc tyvar = lookupOccRn tyvar
 679 \end{code}
 680
 681 %*********************************************************
 682 %*                                                       *
 683 \subsection{IdInfo}
 684 %*                                                       *
 685 %*********************************************************
 686
 687 \begin{code}
 688 rnIdInfo (HsWorker worker arity)
 689   = lookupOccRn worker                  `thenRn` \ worker' ->
 690     returnRn (HsWorker worker' arity)
 691
 692 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' ->
 693                                   returnRn (HsUnfold inline expr')
 694 rnIdInfo (HsStrictness str)     = returnRn (HsStrictness str)
 695 rnIdInfo (HsArity arity)        = returnRn (HsArity arity)
 696 rnIdInfo HsNoCafRefs            = returnRn HsNoCafRefs
 697 rnIdInfo HsCprInfo              = returnRn HsCprInfo
 698 \end{code}
 699
 700 @UfCore@ expressions.
 701
 702 \begin{code}
 703 rnCoreExpr (UfType ty)
 704   = rnHsType (text "unfolding type") ty `thenRn` \ ty' ->
 705     returnRn (UfType ty')
 706
 707 rnCoreExpr (UfVar v)
 708   = lookupOccRn v       `thenRn` \ v' ->
 709     returnRn (UfVar v')
 710
 711 rnCoreExpr (UfLit l)
 712   = returnRn (UfLit l)
 713
 714 rnCoreExpr (UfLitLit l ty)
 715   = rnHsType (text "litlit") ty `thenRn` \ ty' ->
 716     returnRn (UfLitLit l ty')
 717
 718 rnCoreExpr (UfCCall cc ty)
 719   = rnHsType (text "ccall") ty  `thenRn` \ ty' ->
 720     returnRn (UfCCall cc ty')
 721
 722 rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
 723   = mapRn rnCoreExpr args               `thenRn` \ args' ->
 724     returnRn (UfTuple (HsTupCon tup_name boxity arity) args')
 725   where
 726     tup_name = getName (dataConId (tupleCon boxity arity))
 727         -- Get the *worker* name and use that
 728
 729 rnCoreExpr (UfApp fun arg)
 730   = rnCoreExpr fun              `thenRn` \ fun' ->
 731     rnCoreExpr arg              `thenRn` \ arg' ->
 732     returnRn (UfApp fun' arg')
 733
 734 rnCoreExpr (UfCase scrut bndr alts)
 735   = rnCoreExpr scrut                    `thenRn` \ scrut' ->
 736     bindCoreLocalRn bndr                $ \ bndr' ->
 737     mapRn rnCoreAlt alts                `thenRn` \ alts' ->
 738     returnRn (UfCase scrut' bndr' alts')
 739
 740 rnCoreExpr (UfNote note expr)
 741   = rnNote note                 `thenRn` \ note' ->
 742     rnCoreExpr expr             `thenRn` \ expr' ->
 743     returnRn  (UfNote note' expr')
 744
 745 rnCoreExpr (UfLam bndr body)
 746   = rnCoreBndr bndr             $ \ bndr' ->
 747     rnCoreExpr body             `thenRn` \ body' ->
 748     returnRn (UfLam bndr' body')
 749
 750 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 751   = rnCoreExpr rhs              `thenRn` \ rhs' ->
 752     rnCoreBndr bndr             $ \ bndr' ->
 753     rnCoreExpr body             `thenRn` \ body' ->
 754     returnRn (UfLet (UfNonRec bndr' rhs') body')
 755
 756 rnCoreExpr (UfLet (UfRec pairs) body)
 757   = rnCoreBndrs bndrs           $ \ bndrs' ->
 758     mapRn rnCoreExpr rhss       `thenRn` \ rhss' ->
 759     rnCoreExpr body             `thenRn` \ body' ->
 760     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
 761   where
 762     (bndrs, rhss) = unzip pairs
 763 \end{code}
 764
 765 \begin{code}
 766 rnCoreBndr (UfValBinder name ty) thing_inside
 767   = rnHsType doc ty             `thenRn` \ ty' ->
 768     bindCoreLocalRn name        $ \ name' ->
 769     thing_inside (UfValBinder name' ty')
 770   where
 771     doc = text "unfolding id"
 772
 773 rnCoreBndr (UfTyBinder name kind) thing_inside
 774   = bindCoreLocalRn name                $ \ name' ->
 775     thing_inside (UfTyBinder name' kind)
 776
 777 rnCoreBndrs []     thing_inside = thing_inside []
 778 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 779                                   rnCoreBndrs bs        $ \ names' ->
 780                                   thing_inside (name':names')
 781 \end{code}
 782
 783 \begin{code}
 784 rnCoreAlt (con, bndrs, rhs)
 785   = rnUfCon con                         `thenRn` \ con' ->
 786     bindCoreLocalsRn bndrs              $ \ bndrs' ->
 787     rnCoreExpr rhs                      `thenRn` \ rhs' ->
 788     returnRn (con', bndrs', rhs')
 789
 790 rnNote (UfCoerce ty)
 791   = rnHsType (text "unfolding coerce") ty       `thenRn` \ ty' ->
 792     returnRn (UfCoerce ty')
 793
 794 rnNote (UfSCC cc)   = returnRn (UfSCC cc)
 795 rnNote UfInlineCall = returnRn UfInlineCall
 796 rnNote UfInlineMe   = returnRn UfInlineMe
 797
 798
 799 rnUfCon UfDefault
 800   = returnRn UfDefault
 801
 802 rnUfCon (UfTupleAlt (HsTupCon _ boxity arity))
 803   = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity))
 804   where
 805     tup_name = getName (tupleCon boxity arity)
 806
 807 rnUfCon (UfDataAlt con)
 808   = lookupOccRn con             `thenRn` \ con' ->
 809     returnRn (UfDataAlt con')
 810
 811 rnUfCon (UfLitAlt lit)
 812   = returnRn (UfLitAlt lit)
 813
 814 rnUfCon (UfLitLitAlt lit ty)
 815   = rnHsType (text "litlit") ty         `thenRn` \ ty' ->
 816     returnRn (UfLitLitAlt lit ty')
 817 \end{code}
 818
 819 %*********************************************************
 820 %*                                                       *
 821 \subsection{Rule shapes}
 822 %*                                                       *
 823 %*********************************************************
 824
 825 Check the shape of a transformation rule LHS.  Currently
 826 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 827 not one of the @forall@'d variables.
 828
 829 \begin{code}
 830 validRuleLhs foralls lhs
 831   = check lhs
 832   where
 833     check (OpApp _ op _ _)                = check op
 834     check (HsApp e1 e2)                   = check e1
 835     check (HsVar v) | v `notElem` foralls = True
 836     check other                           = False
 837 \end{code}
 838
 839
 840 %*********************************************************
 841 %*                                                       *
 842 \subsection{Errors}
 843 %*                                                       *
 844 %*********************************************************
 845
 846 \begin{code}
 847 derivingNonStdClassErr clas
 848   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 849
 850 badDataCon name
 851    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 852
 853 forAllWarn doc ty tyvar
 854   = ifOptRn Opt_WarnUnusedMatches       $
 855     getModeRn                           `thenRn` \ mode ->
 856     case mode of {
 857 #ifndef DEBUG
 858              InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
 859                                             -- unless DEBUG is on, in which case it is slightly
 860                                             -- informative.  They can arise from mkRhsTyLam,
 861 #endif                                      -- leading to (say)         f :: forall a b. [b] -> [b]
 862              other ->
 863                 addWarnRn (
 864                    sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 865                    nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 866                    $$
 867                    (ptext SLIT("In") <+> doc)
 868                 )
 869           }
 870
 871 badRuleLhsErr name lhs
 872   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 873          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 874     $$
 875     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 876
 877 badRuleVar name var
 878   = sep [ptext SLIT("Rule") <+> doubleQuotes (ptext name) <> colon,
 879          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 880                 ptext SLIT("does not appear on left hand side")]
 881
 882 badExtName :: ExtName -> Message
 883 badExtName ext_nm
 884   = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
 885
 886 dupClassAssertWarn ctxt (assertion : dups)
 887   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 888                quotes (ppr assertion),
 889                ptext SLIT("in the context:")],
 890          nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
 891
 892 naughtyCCallContextErr (HsClassP clas _)
 893   = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
 894          ptext SLIT("in a context")]
 895 \end{code}