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