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