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