ghc/compiler/rename/RnSource.lhs

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