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