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