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