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