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, rdrNameOcc, 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, OccName, nameOccName, 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 ErrUtils         ( Message )
  52 import CStrings         ( isCLabelString )
  53 import ListSetOps       ( removeDupsEq )
  54 \end{code}
  55
  56 @rnSourceDecl@ `renames' declarations.
  57 It simultaneously performs dependency analysis and precedence parsing.
  58 It also does the following error checks:
  59 \begin{enumerate}
  60 \item
  61 Checks that tyvars are used properly. This includes checking
  62 for undefined tyvars, and tyvars in contexts that are ambiguous.
  63 (Some of this checking has now been moved to module @TcMonoType@,
  64 since we don't have functional dependency information at this point.)
  65 \item
  66 Checks that all variable occurences are defined.
  67 \item
  68 Checks the @(..)@ etc constraints in the export list.
  69 \end{enumerate}
  70
  71
  72 %*********************************************************
  73 %*                                                      *
  74 \subsection{Value declarations}
  75 %*                                                      *
  76 %*********************************************************
  77
  78 \begin{code}
  79 rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv
  80               -> [RdrNameHsDecl]
  81               -> RnMG ([RenamedHsDecl], FreeVars)
  82         -- The decls get reversed, but that's ok
  83
  84 rnSourceDecls gbl_env local_fixity_env decls
  85   = initRnMS gbl_env local_fixity_env SourceMode (go emptyFVs [] decls)
  86   where
  87         -- Fixity and deprecations have been dealt with already; ignore them
  88     go fvs ds' []             = returnRn (ds', fvs)
  89     go fvs ds' (FixD _:ds)    = go fvs ds' ds
  90     go fvs ds' (DeprecD _:ds) = go fvs ds' ds
  91     go fvs ds' (d:ds)         = rnSourceDecl d  `thenRn` \(d', fvs') ->
  92                                 go (fvs `plusFV` fvs') (d':ds') ds
  93 \end{code}
  94
  95
  96 %*********************************************************
  97 %*                                                      *
  98 \subsection{Value declarations}
  99 %*                                                      *
 100 %*********************************************************
 101
 102 \begin{code}
 103 -- rnSourceDecl does all the work
 104 rnSourceDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
 105
 106 rnSourceDecl (ValD binds) = rnTopBinds binds    `thenRn` \ (new_binds, fvs) ->
 107                             returnRn (ValD new_binds, fvs)
 108
 109 rnSourceDecl (TyClD tycl_decl)
 110   = rnTyClDecl tycl_decl                `thenRn` \ new_decl ->
 111     rnClassBinds tycl_decl new_decl     `thenRn` \ (new_decl', fvs) ->
 112     traceRn (text "rnClassDecl:" <+> (ppr (nameSetToList (tyClDeclFVs new_decl')) $$
 113                                       ppr (nameSetToList fvs)))         `thenRn_`
 114     returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
 115
 116 rnSourceDecl (InstD inst)
 117   = rnInstDecl inst             `thenRn` \ new_inst ->
 118     rnInstBinds inst new_inst   `thenRn` \ (new_inst', fvs) ->
 119     returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
 120
 121 rnSourceDecl (RuleD rule)
 122   = rnHsRuleDecl rule           `thenRn` \ (new_rule, fvs) ->
 123     returnRn (RuleD new_rule, fvs)
 124
 125 rnSourceDecl (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 rnSourceDecl (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         -- In interface files all types are quantified, so this is a no-op
 325     unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
 326     unquantify glaExys ty                                     = ty
 327
 328 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
 329                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 330                        tcdSysNames = names, tcdLoc = src_loc})
 331   = pushSrcLocRn src_loc $
 332
 333     lookupTopBndrRn cname                       `thenRn` \ cname' ->
 334
 335         -- Deal with the implicit tycon and datacon name
 336         -- They aren't in scope (because they aren't visible to the user)
 337         -- and what we want to do is simply look them up in the cache;
 338         -- we jolly well ought to get a 'hit' there!
 339     mapRn lookupSysBinder names                 `thenRn` \ names' ->
 340
 341         -- Tyvars scope over bindings and context
 342     bindTyVars2Rn cls_doc tyvars                $ \ clas_tyvar_names tyvars' ->
 343
 344         -- Check the superclasses
 345     rnContext cls_doc context                   `thenRn` \ context' ->
 346
 347         -- Check the functional dependencies
 348     rnFds cls_doc fds                           `thenRn` \ fds' ->
 349
 350         -- Check the signatures
 351         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 352     let
 353         (op_sigs, non_op_sigs) = partition isClassOpSig sigs
 354         sig_rdr_names_w_locs   = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
 355     in
 356     checkDupOrQualNames sig_doc sig_rdr_names_w_locs            `thenRn_`
 357     mapRn (rnClassOp cname' clas_tyvar_names fds') op_sigs      `thenRn` \ sigs' ->
 358     let
 359         binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
 360     in
 361     renameSigs (okClsDclSig binders) non_op_sigs          `thenRn` \ non_ops' ->
 362
 363         -- Typechecker is responsible for checking that we only
 364         -- give default-method bindings for things in this class.
 365         -- The renamer *could* check this for class decls, but can't
 366         -- for instance decls.
 367
 368     returnRn (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
 369                           tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
 370                           tcdSysNames = names', tcdLoc = src_loc})
 371   where
 372     cls_doc  = text "the declaration for class"         <+> ppr cname
 373     sig_doc  = text "the signatures for class"          <+> ppr cname
 374
 375 rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn)
 376   = pushSrcLocRn locn $
 377     lookupTopBndrRn op                  `thenRn` \ op_name ->
 378
 379         -- Check the signature
 380     rnHsSigType (quotes (ppr op)) ty    `thenRn` \ new_ty ->
 381
 382         -- Make the default-method name
 383     (case dm_stuff of
 384         DefMeth dm_rdr_name
 385             ->  -- Imported class that has a default method decl
 386                 -- See comments with tname, snames, above
 387                 lookupSysBinder dm_rdr_name     `thenRn` \ dm_name ->
 388                 returnRn (DefMeth dm_name)
 389                         -- An imported class decl for a class decl that had an explicit default
 390                         -- method, mentions, rather than defines,
 391                         -- the default method, so we must arrange to pull it in
 392
 393         GenDefMeth -> returnRn GenDefMeth
 394         NoDefMeth  -> returnRn NoDefMeth
 395     )                                           `thenRn` \ dm_stuff' ->
 396
 397     returnRn (ClassOpSig op_name dm_stuff' new_ty locn)
 398
 399 rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
 400 rnClassBinds (ClassDecl {tcdMeths = Just mbinds})               -- Get mbinds from here
 401  rn_cls_decl@(ClassDecl {tcdTyVars = tyvars, tcdLoc = src_loc}) -- Everything else is here
 402   -- There are some default-method bindings (abeit possibly empty) so
 403   -- this is a source-code class declaration
 404   =     -- The newLocals call is tiresome: given a generic class decl
 405         --      class C a where
 406         --        op :: a -> a
 407         --        op {| x+y |} (Inl a) = ...
 408         --        op {| x+y |} (Inr b) = ...
 409         --        op {| a*b |} (a*b)   = ...
 410         -- we want to name both "x" tyvars with the same unique, so that they are
 411         -- easy to group together in the typechecker.
 412         -- Hence the
 413     extendTyVarEnvFVRn (map hsTyVarName tyvars)         $
 414     getLocalNameEnv                                     `thenRn` \ name_env ->
 415     let
 416         meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
 417         gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
 418                                                 not (tv `elemRdrEnv` name_env)]
 419     in
 420     checkDupOrQualNames meth_doc meth_rdr_names_w_locs  `thenRn_`
 421     newLocalsRn gen_rdr_tyvars_w_locs                   `thenRn` \ gen_tyvars ->
 422     rnMethodBinds gen_tyvars mbinds                     `thenRn` \ (mbinds', meth_fvs) ->
 423     returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
 424   where
 425     meth_doc = text "the default-methods for class"     <+> ppr (tcdName rn_cls_decl)
 426
 427 rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs)
 428         -- Not a class declaration
 429 \end{code}
 430
 431
 432 %*********************************************************
 433 %*                                                      *
 434 \subsection{Support code for type/data declarations}
 435 %*                                                      *
 436 %*********************************************************
 437
 438 \begin{code}
 439 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name])
 440
 441 rnDerivs Nothing -- derivs not specified
 442   = returnRn Nothing
 443
 444 rnDerivs (Just clss)
 445   = mapRn do_one clss   `thenRn` \ clss' ->
 446     returnRn (Just clss')
 447   where
 448     do_one cls = lookupOccRn cls        `thenRn` \ clas_name ->
 449                  checkRn (getUnique clas_name `elem` derivableClassKeys)
 450                          (derivingNonStdClassErr clas_name)     `thenRn_`
 451                  returnRn clas_name
 452 \end{code}
 453
 454 \begin{code}
 455 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 456 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
 457
 458 rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
 459 rnConDecl (ConDecl name wkr tvs cxt details locn)
 460   = pushSrcLocRn locn $
 461     checkConName name           `thenRn_`
 462     lookupTopBndrRn name        `thenRn` \ new_name ->
 463
 464     lookupSysBinder wkr         `thenRn` \ new_wkr ->
 465         -- See comments with ClassDecl
 466
 467     bindTyVarsRn doc tvs                $ \ new_tyvars ->
 468     rnContext doc cxt                   `thenRn` \ new_context ->
 469     rnConDetails doc locn details       `thenRn` \ new_details ->
 470     returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn)
 471   where
 472     doc = text "the definition of data constructor" <+> quotes (ppr name)
 473
 474 rnConDetails doc locn (VanillaCon tys)
 475   = mapRn (rnBangTy doc) tys    `thenRn` \ new_tys  ->
 476     returnRn (VanillaCon new_tys)
 477
 478 rnConDetails doc locn (InfixCon ty1 ty2)
 479   = rnBangTy doc ty1            `thenRn` \ new_ty1 ->
 480     rnBangTy doc ty2            `thenRn` \ new_ty2 ->
 481     returnRn (InfixCon new_ty1 new_ty2)
 482
 483 rnConDetails doc locn (RecCon fields)
 484   = checkDupOrQualNames doc field_names `thenRn_`
 485     mapRn (rnField doc) fields          `thenRn` \ new_fields ->
 486     returnRn (RecCon new_fields)
 487   where
 488     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 489
 490 rnField doc (names, ty)
 491   = mapRn lookupTopBndrRn names `thenRn` \ new_names ->
 492     rnBangTy doc ty             `thenRn` \ new_ty ->
 493     returnRn (new_names, new_ty)
 494
 495 rnBangTy doc (Banged ty)
 496   = rnHsType doc ty             `thenRn` \ new_ty ->
 497     returnRn (Banged new_ty)
 498
 499 rnBangTy doc (Unbanged ty)
 500   = rnHsType doc ty             `thenRn` \ new_ty ->
 501     returnRn (Unbanged new_ty)
 502
 503 rnBangTy doc (Unpacked ty)
 504   = rnHsType doc ty             `thenRn` \ new_ty ->
 505     returnRn (Unpacked new_ty)
 506
 507 -- This data decl will parse OK
 508 --      data T = a Int
 509 -- treating "a" as the constructor.
 510 -- It is really hard to make the parser spot this malformation.
 511 -- So the renamer has to check that the constructor is legal
 512 --
 513 -- We can get an operator as the constructor, even in the prefix form:
 514 --      data T = :% Int Int
 515 -- from interface files, which always print in prefix form
 516
 517 checkConName name
 518   = checkRn (isRdrDataCon name)
 519             (badDataCon name)
 520 \end{code}
 521
 522
 523 %*********************************************************
 524 %*                                                      *
 525 \subsection{Support code to rename types}
 526 %*                                                      *
 527 %*********************************************************
 528
 529 \begin{code}
 530 rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 531 rnHsTypeFVs doc_str ty
 532   = rnHsType doc_str ty         `thenRn` \ ty' ->
 533     returnRn (ty', extractHsTyNames ty')
 534
 535 rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 536 rnHsSigTypeFVs doc_str ty
 537   = rnHsSigType doc_str ty      `thenRn` \ ty' ->
 538     returnRn (ty', extractHsTyNames ty')
 539
 540 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
 541         -- rnHsSigType is used for source-language type signatures,
 542         -- which use *implicit* universal quantification.
 543 rnHsSigType doc_str ty
 544   = rnHsType (text "the type signature for" <+> doc_str) ty
 545
 546 ---------------------------------------
 547 rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
 548
 549 rnHsType doc (HsForAllTy Nothing ctxt ty)
 550         -- Implicit quantifiction in source code (no kinds on tyvars)
 551         -- Given the signature  C => T  we universally quantify
 552         -- over FV(T) \ {in-scope-tyvars}
 553   = getLocalNameEnv             `thenRn` \ name_env ->
 554     let
 555         mentioned_in_tau  = extractHsTyRdrTyVars ty
 556         mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
 557         mentioned         = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 558         forall_tyvars     = filter (not . (`elemRdrEnv` name_env)) mentioned
 559     in
 560     rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
 561
 562 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 563         -- Explicit quantification.
 564         -- Check that the forall'd tyvars are actually
 565         -- mentioned in the type, and produce a warning if not
 566   = let
 567         mentioned_in_tau                = extractHsTyRdrTyVars tau
 568         mentioned_in_ctxt               = extractHsCtxtRdrTyVars ctxt
 569         mentioned                       = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 570         forall_tyvar_names              = hsTyVarNames forall_tyvars
 571
 572         -- Explicitly quantified but not mentioned in ctxt or tau
 573         warn_guys                       = filter (`notElem` mentioned) forall_tyvar_names
 574     in
 575     mapRn_ (forAllWarn doc tau) warn_guys       `thenRn_`
 576     rnForAll doc forall_tyvars ctxt tau
 577
 578 rnHsType doc (HsTyVar tyvar)
 579   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 580     returnRn (HsTyVar tyvar')
 581
 582 rnHsType doc (HsOpTy ty1 opname ty2)
 583   = lookupOccRn opname  `thenRn` \ name' ->
 584     rnHsType doc ty1    `thenRn` \ ty1' ->
 585     rnHsType doc ty2    `thenRn` \ ty2' ->
 586     returnRn (HsOpTy ty1' name' ty2')
 587
 588 rnHsType doc (HsNumTy i)
 589   | i == 1    = returnRn (HsNumTy i)
 590   | otherwise = failWithRn (HsNumTy i)
 591                            (ptext SLIT("Only unit numeric type pattern is valid"))
 592
 593 rnHsType doc (HsFunTy ty1 ty2)
 594   = rnHsType doc ty1    `thenRn` \ ty1' ->
 595         -- Might find a for-all as the arg of a function type
 596     rnHsType doc ty2    `thenRn` \ ty2' ->
 597         -- Or as the result.  This happens when reading Prelude.hi
 598         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 599     returnRn (HsFunTy ty1' ty2')
 600
 601 rnHsType doc (HsListTy ty)
 602   = rnHsType doc ty                             `thenRn` \ ty' ->
 603     returnRn (HsListTy ty')
 604
 605 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 606 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 607 rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys)
 608         -- Don't do lookupOccRn, because this is built-in syntax
 609         -- so it doesn't need to be in scope
 610   = mapRn (rnHsType doc) tys            `thenRn` \ tys' ->
 611     returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys')
 612   where
 613     tup_name = tupleTyCon_name boxity arity
 614
 615
 616 rnHsType doc (HsAppTy ty1 ty2)
 617   = rnHsType doc ty1            `thenRn` \ ty1' ->
 618     rnHsType doc ty2            `thenRn` \ ty2' ->
 619     returnRn (HsAppTy ty1' ty2')
 620
 621 rnHsType doc (HsPredTy pred)
 622   = rnPred doc pred     `thenRn` \ pred' ->
 623     returnRn (HsPredTy pred')
 624
 625 rnHsTypes doc tys = mapRn (rnHsType doc) tys
 626 \end{code}
 627
 628 \begin{code}
 629 rnForAll doc forall_tyvars ctxt ty
 630   = bindTyVarsRn doc forall_tyvars      $ \ new_tyvars ->
 631     rnContext doc ctxt                  `thenRn` \ new_ctxt ->
 632     rnHsType doc ty                     `thenRn` \ new_ty ->
 633     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
 634 \end{code}
 635
 636 \begin{code}
 637 rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext
 638 rnContext doc ctxt
 639   = mapRn rn_pred ctxt          `thenRn` \ theta ->
 640     let
 641         (_, dups) = removeDupsEq theta
 642                 -- We only have equality, not ordering
 643     in
 644         -- Check for duplicate assertions
 645         -- If this isn't an error, then it ought to be:
 646     mapRn (addWarnRn . dupClassAssertWarn theta) dups           `thenRn_`
 647     returnRn theta
 648   where
 649         --Someone discovered that @CCallable@ and @CReturnable@
 650         -- could be used in contexts such as:
 651         --      foo :: CCallable a => a -> PrimIO Int
 652         -- Doing this utterly wrecks the whole point of introducing these
 653         -- classes so we specifically check that this isn't being done.
 654     rn_pred pred = rnPred doc pred                              `thenRn` \ pred'->
 655                    checkRn (not (bad_pred pred'))
 656                            (naughtyCCallContextErr pred')       `thenRn_`
 657                    returnRn pred'
 658
 659     bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
 660     bad_pred other             = False
 661
 662
 663 rnPred doc (HsPClass clas tys)
 664   = lookupOccRn clas            `thenRn` \ clas_name ->
 665     rnHsTypes doc tys           `thenRn` \ tys' ->
 666     returnRn (HsPClass clas_name tys')
 667
 668 rnPred doc (HsPIParam n ty)
 669   = newIPName n                 `thenRn` \ name ->
 670     rnHsType doc ty             `thenRn` \ ty' ->
 671     returnRn (HsPIParam name ty')
 672 \end{code}
 673
 674 \begin{code}
 675 rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name]
 676
 677 rnFds doc fds
 678   = mapRn rn_fds fds
 679   where
 680     rn_fds (tys1, tys2)
 681       = rnHsTyVars doc tys1             `thenRn` \ tys1' ->
 682         rnHsTyVars doc tys2             `thenRn` \ tys2' ->
 683         returnRn (tys1', tys2')
 684
 685 rnHsTyVars doc tvs  = mapRn (rnHsTyvar doc) tvs
 686 rnHsTyvar doc tyvar = lookupOccRn tyvar
 687 \end{code}
 688
 689 %*********************************************************
 690 %*                                                       *
 691 \subsection{IdInfo}
 692 %*                                                       *
 693 %*********************************************************
 694
 695 \begin{code}
 696 rnIdInfo (HsWorker worker)
 697   = lookupOccRn worker                  `thenRn` \ worker' ->
 698     returnRn (HsWorker worker')
 699
 700 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' ->
 701                                   returnRn (HsUnfold inline expr')
 702 rnIdInfo (HsStrictness str)     = returnRn (HsStrictness str)
 703 rnIdInfo (HsArity arity)        = returnRn (HsArity arity)
 704 rnIdInfo HsNoCafRefs            = returnRn HsNoCafRefs
 705 rnIdInfo HsCprInfo              = returnRn HsCprInfo
 706 \end{code}
 707
 708 @UfCore@ expressions.
 709
 710 \begin{code}
 711 rnCoreExpr (UfType ty)
 712   = rnHsType (text "unfolding type") ty `thenRn` \ ty' ->
 713     returnRn (UfType ty')
 714
 715 rnCoreExpr (UfVar v)
 716   = lookupOccRn v       `thenRn` \ v' ->
 717     returnRn (UfVar v')
 718
 719 rnCoreExpr (UfLit l)
 720   = returnRn (UfLit l)
 721
 722 rnCoreExpr (UfLitLit l ty)
 723   = rnHsType (text "litlit") ty `thenRn` \ ty' ->
 724     returnRn (UfLitLit l ty')
 725
 726 rnCoreExpr (UfCCall cc ty)
 727   = rnHsType (text "ccall") ty  `thenRn` \ ty' ->
 728     returnRn (UfCCall cc ty')
 729
 730 rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
 731   = mapRn rnCoreExpr args               `thenRn` \ args' ->
 732     returnRn (UfTuple (HsTupCon tup_name boxity arity) args')
 733   where
 734     tup_name = getName (dataConId (tupleCon boxity arity))
 735         -- Get the *worker* name and use that
 736
 737 rnCoreExpr (UfApp fun arg)
 738   = rnCoreExpr fun              `thenRn` \ fun' ->
 739     rnCoreExpr arg              `thenRn` \ arg' ->
 740     returnRn (UfApp fun' arg')
 741
 742 rnCoreExpr (UfCase scrut bndr alts)
 743   = rnCoreExpr scrut                    `thenRn` \ scrut' ->
 744     bindCoreLocalRn bndr                $ \ bndr' ->
 745     mapRn rnCoreAlt alts                `thenRn` \ alts' ->
 746     returnRn (UfCase scrut' bndr' alts')
 747
 748 rnCoreExpr (UfNote note expr)
 749   = rnNote note                 `thenRn` \ note' ->
 750     rnCoreExpr expr             `thenRn` \ expr' ->
 751     returnRn  (UfNote note' expr')
 752
 753 rnCoreExpr (UfLam bndr body)
 754   = rnCoreBndr bndr             $ \ bndr' ->
 755     rnCoreExpr body             `thenRn` \ body' ->
 756     returnRn (UfLam bndr' body')
 757
 758 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 759   = rnCoreExpr rhs              `thenRn` \ rhs' ->
 760     rnCoreBndr bndr             $ \ bndr' ->
 761     rnCoreExpr body             `thenRn` \ body' ->
 762     returnRn (UfLet (UfNonRec bndr' rhs') body')
 763
 764 rnCoreExpr (UfLet (UfRec pairs) body)
 765   = rnCoreBndrs bndrs           $ \ bndrs' ->
 766     mapRn rnCoreExpr rhss       `thenRn` \ rhss' ->
 767     rnCoreExpr body             `thenRn` \ body' ->
 768     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
 769   where
 770     (bndrs, rhss) = unzip pairs
 771 \end{code}
 772
 773 \begin{code}
 774 rnCoreBndr (UfValBinder name ty) thing_inside
 775   = rnHsType doc ty             `thenRn` \ ty' ->
 776     bindCoreLocalRn name        $ \ name' ->
 777     thing_inside (UfValBinder name' ty')
 778   where
 779     doc = text "unfolding id"
 780
 781 rnCoreBndr (UfTyBinder name kind) thing_inside
 782   = bindCoreLocalRn name                $ \ name' ->
 783     thing_inside (UfTyBinder name' kind)
 784
 785 rnCoreBndrs []     thing_inside = thing_inside []
 786 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 787                                   rnCoreBndrs bs        $ \ names' ->
 788                                   thing_inside (name':names')
 789 \end{code}
 790
 791 \begin{code}
 792 rnCoreAlt (con, bndrs, rhs)
 793   = rnUfCon con                         `thenRn` \ con' ->
 794     bindCoreLocalsRn bndrs              $ \ bndrs' ->
 795     rnCoreExpr rhs                      `thenRn` \ rhs' ->
 796     returnRn (con', bndrs', rhs')
 797
 798 rnNote (UfCoerce ty)
 799   = rnHsType (text "unfolding coerce") ty       `thenRn` \ ty' ->
 800     returnRn (UfCoerce ty')
 801
 802 rnNote (UfSCC cc)   = returnRn (UfSCC cc)
 803 rnNote UfInlineCall = returnRn UfInlineCall
 804 rnNote UfInlineMe   = returnRn UfInlineMe
 805
 806
 807 rnUfCon UfDefault
 808   = returnRn UfDefault
 809
 810 rnUfCon (UfTupleAlt (HsTupCon _ boxity arity))
 811   = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity))
 812   where
 813     tup_name = getName (tupleCon boxity arity)
 814
 815 rnUfCon (UfDataAlt con)
 816   = lookupOccRn con             `thenRn` \ con' ->
 817     returnRn (UfDataAlt con')
 818
 819 rnUfCon (UfLitAlt lit)
 820   = returnRn (UfLitAlt lit)
 821
 822 rnUfCon (UfLitLitAlt lit ty)
 823   = rnHsType (text "litlit") ty         `thenRn` \ ty' ->
 824     returnRn (UfLitLitAlt lit ty')
 825 \end{code}
 826
 827 %*********************************************************
 828 %*                                                       *
 829 \subsection{Rule shapes}
 830 %*                                                       *
 831 %*********************************************************
 832
 833 Check the shape of a transformation rule LHS.  Currently
 834 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 835 not one of the @forall@'d variables.
 836
 837 \begin{code}
 838 validRuleLhs foralls lhs
 839   = check lhs
 840   where
 841     check (HsApp e1 e2)                   = check e1
 842     check (HsVar v) | v `notElem` foralls = True
 843     check other                           = False
 844 \end{code}
 845
 846
 847 %*********************************************************
 848 %*                                                       *
 849 \subsection{Errors}
 850 %*                                                       *
 851 %*********************************************************
 852
 853 \begin{code}
 854 derivingNonStdClassErr clas
 855   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 856
 857 badDataCon name
 858    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 859
 860 forAllWarn doc ty tyvar
 861   = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of
 862     () | not warn_unused -> returnRn ()
 863        | otherwise
 864        -> getModeRn             `thenRn` \ mode ->
 865           case mode of {
 866 #ifndef DEBUG
 867              InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
 868                                             -- unless DEBUG is on, in which case it is slightly
 869                                             -- informative.  They can arise from mkRhsTyLam,
 870 #endif                                      -- leading to (say)         f :: forall a b. [b] -> [b]
 871              other ->
 872                 addWarnRn (
 873                    sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 874                    nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 875                    $$
 876                    (ptext SLIT("In") <+> doc)
 877                 )
 878           }
 879
 880 badRuleLhsErr name lhs
 881   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 882          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 883     $$
 884     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 885
 886 badRuleVar name var
 887   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 888          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 889                 ptext SLIT("does not appear on left hand side")]
 890
 891 badExtName :: ExtName -> Message
 892 badExtName ext_nm
 893   = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
 894
 895 dupClassAssertWarn ctxt (assertion : dups)
 896   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 897                quotes (ppr assertion),
 898                ptext SLIT("in the context:")],
 899          nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
 900
 901 naughtyCCallContextErr (HsPClass clas _)
 902   = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
 903          ptext SLIT("in a context")]
 904 \end{code}