ghc/compiler/rename/RnSource.lhs

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