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   -- Rename the mbinds only; the rest is done already
 400 rnClassBinds (ClassDecl {tcdMeths = Nothing}) rn_cls_decl
 401   = returnRn (rn_cls_decl, emptyFVs)    -- No meth binds; decl came from interface file
 402
 403 rnClassBinds (ClassDecl {tcdMeths = Just mbinds})                               -- Get mbinds from here
 404              rn_cls_decl@(ClassDecl {tcdTyVars = tyvars, tcdLoc = src_loc})     -- Everything else is here
 405   =     -- The newLocals call is tiresome: given a generic class decl
 406         --      class C a where
 407         --        op :: a -> a
 408         --        op {| x+y |} (Inl a) = ...
 409         --        op {| x+y |} (Inr b) = ...
 410         --        op {| a*b |} (a*b)   = ...
 411         -- we want to name both "x" tyvars with the same unique, so that they are
 412         -- easy to group together in the typechecker.
 413         -- Hence the
 414     extendTyVarEnvFVRn (map hsTyVarName tyvars)         $
 415     getLocalNameEnv                                     `thenRn` \ name_env ->
 416     let
 417         meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
 418         gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
 419                                                 not (tv `elemRdrEnv` name_env)]
 420     in
 421     checkDupOrQualNames meth_doc meth_rdr_names_w_locs  `thenRn_`
 422     newLocalsRn gen_rdr_tyvars_w_locs                   `thenRn` \ gen_tyvars ->
 423     rnMethodBinds gen_tyvars mbinds                     `thenRn` \ (mbinds', meth_fvs) ->
 424     returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
 425   where
 426     meth_doc = text "the default-methods for class"     <+> ppr (tcdName rn_cls_decl)
 427
 428 rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs)
 429         -- Not a class declaration
 430 \end{code}
 431
 432
 433 %*********************************************************
 434 %*                                                      *
 435 \subsection{Support code for type/data declarations}
 436 %*                                                      *
 437 %*********************************************************
 438
 439 \begin{code}
 440 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name])
 441
 442 rnDerivs Nothing -- derivs not specified
 443   = returnRn Nothing
 444
 445 rnDerivs (Just clss)
 446   = mapRn do_one clss   `thenRn` \ clss' ->
 447     returnRn (Just clss')
 448   where
 449     do_one cls = lookupOccRn cls        `thenRn` \ clas_name ->
 450                  checkRn (getUnique clas_name `elem` derivableClassKeys)
 451                          (derivingNonStdClassErr clas_name)     `thenRn_`
 452                  returnRn clas_name
 453 \end{code}
 454
 455 \begin{code}
 456 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 457 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
 458
 459 rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
 460 rnConDecl (ConDecl name wkr tvs cxt details locn)
 461   = pushSrcLocRn locn $
 462     checkConName name           `thenRn_`
 463     lookupTopBndrRn name        `thenRn` \ new_name ->
 464
 465     lookupSysBinder wkr         `thenRn` \ new_wkr ->
 466         -- See comments with ClassDecl
 467
 468     bindTyVarsRn doc tvs                $ \ new_tyvars ->
 469     rnContext doc cxt                   `thenRn` \ new_context ->
 470     rnConDetails doc locn details       `thenRn` \ new_details ->
 471     returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn)
 472   where
 473     doc = text "the definition of data constructor" <+> quotes (ppr name)
 474
 475 rnConDetails doc locn (VanillaCon tys)
 476   = mapRn (rnBangTy doc) tys    `thenRn` \ new_tys  ->
 477     returnRn (VanillaCon new_tys)
 478
 479 rnConDetails doc locn (InfixCon ty1 ty2)
 480   = rnBangTy doc ty1            `thenRn` \ new_ty1 ->
 481     rnBangTy doc ty2            `thenRn` \ new_ty2 ->
 482     returnRn (InfixCon new_ty1 new_ty2)
 483
 484 rnConDetails doc locn (RecCon fields)
 485   = checkDupOrQualNames doc field_names `thenRn_`
 486     mapRn (rnField doc) fields          `thenRn` \ new_fields ->
 487     returnRn (RecCon new_fields)
 488   where
 489     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 490
 491 rnField doc (names, ty)
 492   = mapRn lookupTopBndrRn names `thenRn` \ new_names ->
 493     rnBangTy doc ty             `thenRn` \ new_ty ->
 494     returnRn (new_names, new_ty)
 495
 496 rnBangTy doc (Banged ty)
 497   = rnHsType doc ty             `thenRn` \ new_ty ->
 498     returnRn (Banged new_ty)
 499
 500 rnBangTy doc (Unbanged ty)
 501   = rnHsType doc ty             `thenRn` \ new_ty ->
 502     returnRn (Unbanged new_ty)
 503
 504 rnBangTy doc (Unpacked ty)
 505   = rnHsType doc ty             `thenRn` \ new_ty ->
 506     returnRn (Unpacked new_ty)
 507
 508 -- This data decl will parse OK
 509 --      data T = a Int
 510 -- treating "a" as the constructor.
 511 -- It is really hard to make the parser spot this malformation.
 512 -- So the renamer has to check that the constructor is legal
 513 --
 514 -- We can get an operator as the constructor, even in the prefix form:
 515 --      data T = :% Int Int
 516 -- from interface files, which always print in prefix form
 517
 518 checkConName name
 519   = checkRn (isRdrDataCon name)
 520             (badDataCon name)
 521 \end{code}
 522
 523
 524 %*********************************************************
 525 %*                                                      *
 526 \subsection{Support code to rename types}
 527 %*                                                      *
 528 %*********************************************************
 529
 530 \begin{code}
 531 rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 532 rnHsTypeFVs doc_str ty
 533   = rnHsType doc_str ty         `thenRn` \ ty' ->
 534     returnRn (ty', extractHsTyNames ty')
 535
 536 rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 537 rnHsSigTypeFVs doc_str ty
 538   = rnHsSigType doc_str ty      `thenRn` \ ty' ->
 539     returnRn (ty', extractHsTyNames ty')
 540
 541 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
 542         -- rnHsSigType is used for source-language type signatures,
 543         -- which use *implicit* universal quantification.
 544 rnHsSigType doc_str ty
 545   = rnHsType (text "the type signature for" <+> doc_str) ty
 546
 547 ---------------------------------------
 548 rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
 549
 550 rnHsType doc (HsForAllTy Nothing ctxt ty)
 551         -- Implicit quantifiction in source code (no kinds on tyvars)
 552         -- Given the signature  C => T  we universally quantify
 553         -- over FV(T) \ {in-scope-tyvars}
 554   = getLocalNameEnv             `thenRn` \ name_env ->
 555     let
 556         mentioned_in_tau  = extractHsTyRdrTyVars ty
 557         mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
 558         mentioned         = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 559         forall_tyvars     = filter (not . (`elemRdrEnv` name_env)) mentioned
 560     in
 561     rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
 562
 563 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 564         -- Explicit quantification.
 565         -- Check that the forall'd tyvars are actually
 566         -- mentioned in the type, and produce a warning if not
 567   = let
 568         mentioned_in_tau                = extractHsTyRdrTyVars tau
 569         mentioned_in_ctxt               = extractHsCtxtRdrTyVars ctxt
 570         mentioned                       = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 571         forall_tyvar_names              = hsTyVarNames forall_tyvars
 572
 573         -- Explicitly quantified but not mentioned in ctxt or tau
 574         warn_guys                       = filter (`notElem` mentioned) forall_tyvar_names
 575     in
 576     mapRn_ (forAllWarn doc tau) warn_guys       `thenRn_`
 577     rnForAll doc forall_tyvars ctxt tau
 578
 579 rnHsType doc (HsTyVar tyvar)
 580   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 581     returnRn (HsTyVar tyvar')
 582
 583 rnHsType doc (HsOpTy ty1 opname ty2)
 584   = lookupOccRn opname  `thenRn` \ name' ->
 585     rnHsType doc ty1    `thenRn` \ ty1' ->
 586     rnHsType doc ty2    `thenRn` \ ty2' ->
 587     returnRn (HsOpTy ty1' name' ty2')
 588
 589 rnHsType doc (HsNumTy i)
 590   | i == 1    = returnRn (HsNumTy i)
 591   | otherwise = failWithRn (HsNumTy i)
 592                            (ptext SLIT("Only unit numeric type pattern is valid"))
 593
 594 rnHsType doc (HsFunTy ty1 ty2)
 595   = rnHsType doc ty1    `thenRn` \ ty1' ->
 596         -- Might find a for-all as the arg of a function type
 597     rnHsType doc ty2    `thenRn` \ ty2' ->
 598         -- Or as the result.  This happens when reading Prelude.hi
 599         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 600     returnRn (HsFunTy ty1' ty2')
 601
 602 rnHsType doc (HsListTy ty)
 603   = rnHsType doc ty                             `thenRn` \ ty' ->
 604     returnRn (HsListTy ty')
 605
 606 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 607 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 608 rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
 609         -- Don't do lookupOccRn, because this is built-in syntax
 610         -- so it doesn't need to be in scope
 611   = mapRn (rnHsType doc) tys            `thenRn` \ tys' ->
 612     returnRn (HsTupleTy (HsTupCon n' boxity) tys')
 613   where
 614     n' = tupleTyCon_name boxity (length tys)
 615
 616
 617 rnHsType doc (HsAppTy ty1 ty2)
 618   = rnHsType doc ty1            `thenRn` \ ty1' ->
 619     rnHsType doc ty2            `thenRn` \ ty2' ->
 620     returnRn (HsAppTy ty1' ty2')
 621
 622 rnHsType doc (HsPredTy pred)
 623   = rnPred doc pred     `thenRn` \ pred' ->
 624     returnRn (HsPredTy pred')
 625
 626 rnHsTypes doc tys = mapRn (rnHsType doc) tys
 627 \end{code}
 628
 629 \begin{code}
 630 -- We use lookupOcc here because this is interface file only stuff
 631 -- and we need the workers...
 632 rnHsTupCon (HsTupCon n boxity)
 633   = lookupOccRn n       `thenRn` \ n' ->
 634     returnRn (HsTupCon n' boxity)
 635
 636 rnHsTupConWkr (HsTupCon n boxity)
 637         -- Tuple construtors are for the *worker* of the tuple
 638         -- Going direct saves needless messing about
 639   = lookupOccRn (mkRdrNameWkr n)        `thenRn` \ n' ->
 640     returnRn (HsTupCon n' boxity)
 641 \end{code}
 642
 643 \begin{code}
 644 rnForAll doc forall_tyvars ctxt ty
 645   = bindTyVarsRn doc forall_tyvars      $ \ new_tyvars ->
 646     rnContext doc ctxt                  `thenRn` \ new_ctxt ->
 647     rnHsType doc ty                     `thenRn` \ new_ty ->
 648     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
 649 \end{code}
 650
 651 \begin{code}
 652 rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext
 653 rnContext doc ctxt
 654   = mapRn rn_pred ctxt          `thenRn` \ theta ->
 655     let
 656         (_, dups) = removeDupsEq theta
 657                 -- We only have equality, not ordering
 658     in
 659         -- Check for duplicate assertions
 660         -- If this isn't an error, then it ought to be:
 661     mapRn (addWarnRn . dupClassAssertWarn theta) dups           `thenRn_`
 662     returnRn theta
 663   where
 664         --Someone discovered that @CCallable@ and @CReturnable@
 665         -- could be used in contexts such as:
 666         --      foo :: CCallable a => a -> PrimIO Int
 667         -- Doing this utterly wrecks the whole point of introducing these
 668         -- classes so we specifically check that this isn't being done.
 669     rn_pred pred = rnPred doc pred                              `thenRn` \ pred'->
 670                    checkRn (not (bad_pred pred'))
 671                            (naughtyCCallContextErr pred')       `thenRn_`
 672                    returnRn pred'
 673
 674     bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
 675     bad_pred other             = False
 676
 677
 678 rnPred doc (HsPClass clas tys)
 679   = lookupOccRn clas            `thenRn` \ clas_name ->
 680     rnHsTypes doc tys           `thenRn` \ tys' ->
 681     returnRn (HsPClass clas_name tys')
 682
 683 rnPred doc (HsPIParam n ty)
 684   = newIPName n                 `thenRn` \ name ->
 685     rnHsType doc ty             `thenRn` \ ty' ->
 686     returnRn (HsPIParam name ty')
 687 \end{code}
 688
 689 \begin{code}
 690 rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name]
 691
 692 rnFds doc fds
 693   = mapRn rn_fds fds
 694   where
 695     rn_fds (tys1, tys2)
 696       = rnHsTyVars doc tys1             `thenRn` \ tys1' ->
 697         rnHsTyVars doc tys2             `thenRn` \ tys2' ->
 698         returnRn (tys1', tys2')
 699
 700 rnHsTyVars doc tvs  = mapRn (rnHsTyvar doc) tvs
 701 rnHsTyvar doc tyvar = lookupOccRn tyvar
 702 \end{code}
 703
 704 %*********************************************************
 705 %*                                                       *
 706 \subsection{IdInfo}
 707 %*                                                       *
 708 %*********************************************************
 709
 710 \begin{code}
 711 rnIdInfo (HsWorker worker)
 712   = lookupOccRn worker                  `thenRn` \ worker' ->
 713     returnRn (HsWorker worker')
 714
 715 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' ->
 716                                   returnRn (HsUnfold inline expr')
 717 rnIdInfo (HsStrictness str)     = returnRn (HsStrictness str)
 718 rnIdInfo (HsArity arity)        = returnRn (HsArity arity)
 719 rnIdInfo HsNoCafRefs            = returnRn HsNoCafRefs
 720 rnIdInfo HsCprInfo              = returnRn HsCprInfo
 721 \end{code}
 722
 723 @UfCore@ expressions.
 724
 725 \begin{code}
 726 rnCoreExpr (UfType ty)
 727   = rnHsType (text "unfolding type") ty `thenRn` \ ty' ->
 728     returnRn (UfType ty')
 729
 730 rnCoreExpr (UfVar v)
 731   = lookupOccRn v       `thenRn` \ v' ->
 732     returnRn (UfVar v')
 733
 734 rnCoreExpr (UfLit l)
 735   = returnRn (UfLit l)
 736
 737 rnCoreExpr (UfLitLit l ty)
 738   = rnHsType (text "litlit") ty `thenRn` \ ty' ->
 739     returnRn (UfLitLit l ty')
 740
 741 rnCoreExpr (UfCCall cc ty)
 742   = rnHsType (text "ccall") ty  `thenRn` \ ty' ->
 743     returnRn (UfCCall cc ty')
 744
 745 rnCoreExpr (UfTuple con args)
 746   = rnHsTupConWkr con                   `thenRn` \ con' ->
 747     mapRn rnCoreExpr args               `thenRn` \ args' ->
 748     returnRn (UfTuple con' args')
 749
 750 rnCoreExpr (UfApp fun arg)
 751   = rnCoreExpr fun              `thenRn` \ fun' ->
 752     rnCoreExpr arg              `thenRn` \ arg' ->
 753     returnRn (UfApp fun' arg')
 754
 755 rnCoreExpr (UfCase scrut bndr alts)
 756   = rnCoreExpr scrut                    `thenRn` \ scrut' ->
 757     bindCoreLocalRn bndr                $ \ bndr' ->
 758     mapRn rnCoreAlt alts                `thenRn` \ alts' ->
 759     returnRn (UfCase scrut' bndr' alts')
 760
 761 rnCoreExpr (UfNote note expr)
 762   = rnNote note                 `thenRn` \ note' ->
 763     rnCoreExpr expr             `thenRn` \ expr' ->
 764     returnRn  (UfNote note' expr')
 765
 766 rnCoreExpr (UfLam bndr body)
 767   = rnCoreBndr bndr             $ \ bndr' ->
 768     rnCoreExpr body             `thenRn` \ body' ->
 769     returnRn (UfLam bndr' body')
 770
 771 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 772   = rnCoreExpr rhs              `thenRn` \ rhs' ->
 773     rnCoreBndr bndr             $ \ bndr' ->
 774     rnCoreExpr body             `thenRn` \ body' ->
 775     returnRn (UfLet (UfNonRec bndr' rhs') body')
 776
 777 rnCoreExpr (UfLet (UfRec pairs) body)
 778   = rnCoreBndrs bndrs           $ \ bndrs' ->
 779     mapRn rnCoreExpr rhss       `thenRn` \ rhss' ->
 780     rnCoreExpr body             `thenRn` \ body' ->
 781     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
 782   where
 783     (bndrs, rhss) = unzip pairs
 784 \end{code}
 785
 786 \begin{code}
 787 rnCoreBndr (UfValBinder name ty) thing_inside
 788   = rnHsType doc ty             `thenRn` \ ty' ->
 789     bindCoreLocalRn name        $ \ name' ->
 790     thing_inside (UfValBinder name' ty')
 791   where
 792     doc = text "unfolding id"
 793
 794 rnCoreBndr (UfTyBinder name kind) thing_inside
 795   = bindCoreLocalRn name                $ \ name' ->
 796     thing_inside (UfTyBinder name' kind)
 797
 798 rnCoreBndrs []     thing_inside = thing_inside []
 799 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 800                                   rnCoreBndrs bs        $ \ names' ->
 801                                   thing_inside (name':names')
 802 \end{code}
 803
 804 \begin{code}
 805 rnCoreAlt (con, bndrs, rhs)
 806   = rnUfCon con bndrs                   `thenRn` \ con' ->
 807     bindCoreLocalsRn bndrs              $ \ bndrs' ->
 808     rnCoreExpr rhs                      `thenRn` \ rhs' ->
 809     returnRn (con', bndrs', rhs')
 810
 811 rnNote (UfCoerce ty)
 812   = rnHsType (text "unfolding coerce") ty       `thenRn` \ ty' ->
 813     returnRn (UfCoerce ty')
 814
 815 rnNote (UfSCC cc)   = returnRn (UfSCC cc)
 816 rnNote UfInlineCall = returnRn UfInlineCall
 817 rnNote UfInlineMe   = returnRn UfInlineMe
 818
 819
 820 rnUfCon UfDefault _
 821   = returnRn UfDefault
 822
 823 rnUfCon (UfTupleAlt tup_con) bndrs
 824   = rnHsTupCon tup_con          `thenRn` \ (HsTupCon con' _) ->
 825     returnRn (UfDataAlt con')
 826         -- Makes the type checker a little easier
 827
 828 rnUfCon (UfDataAlt con) _
 829   = lookupOccRn con             `thenRn` \ con' ->
 830     returnRn (UfDataAlt con')
 831
 832 rnUfCon (UfLitAlt lit) _
 833   = returnRn (UfLitAlt lit)
 834
 835 rnUfCon (UfLitLitAlt lit ty) _
 836   = rnHsType (text "litlit") ty         `thenRn` \ ty' ->
 837     returnRn (UfLitLitAlt lit ty')
 838 \end{code}
 839
 840 %*********************************************************
 841 %*                                                       *
 842 \subsection{Rule shapes}
 843 %*                                                       *
 844 %*********************************************************
 845
 846 Check the shape of a transformation rule LHS.  Currently
 847 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 848 not one of the @forall@'d variables.
 849
 850 \begin{code}
 851 validRuleLhs foralls lhs
 852   = check lhs
 853   where
 854     check (HsApp e1 e2)                   = check e1
 855     check (HsVar v) | v `notElem` foralls = True
 856     check other                           = False
 857 \end{code}
 858
 859
 860 %*********************************************************
 861 %*                                                       *
 862 \subsection{Errors}
 863 %*                                                       *
 864 %*********************************************************
 865
 866 \begin{code}
 867 derivingNonStdClassErr clas
 868   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 869
 870 badDataCon name
 871    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 872
 873 forAllWarn doc ty tyvar
 874   = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of
 875     () | not warn_unused -> returnRn ()
 876        | otherwise
 877        -> getModeRn             `thenRn` \ mode ->
 878           case mode of {
 879 #ifndef DEBUG
 880              InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
 881                                             -- unless DEBUG is on, in which case it is slightly
 882                                             -- informative.  They can arise from mkRhsTyLam,
 883 #endif                                      -- leading to (say)         f :: forall a b. [b] -> [b]
 884              other ->
 885                 addWarnRn (
 886                    sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 887                    nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 888                    $$
 889                    (ptext SLIT("In") <+> doc)
 890                 )
 891           }
 892
 893 badRuleLhsErr name lhs
 894   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 895          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 896     $$
 897     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 898
 899 badRuleVar name var
 900   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 901          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 902                 ptext SLIT("does not appear on left hand side")]
 903
 904 badExtName :: ExtName -> Message
 905 badExtName ext_nm
 906   = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
 907
 908 dupClassAssertWarn ctxt (assertion : dups)
 909   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 910                quotes (ppr assertion),
 911                ptext SLIT("in the context:")],
 912          nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
 913
 914 naughtyCCallContextErr (HsPClass clas _)
 915   = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
 916          ptext SLIT("in a context")]
 917 \end{code}