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