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 ( rnIfaceDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
   8
   9 #include "HsVersions.h"
  10
  11 import RnExpr
  12 import HsSyn
  13 import HsDecls          ( HsIdInfo(..), HsStrictnessInfo(..) )
  14 import HsPragmas
  15 import HsTypes          ( getTyVarName, pprClassAssertion, cmpHsTypes )
  16 import RdrName          ( RdrName, isRdrDataCon, rdrNameOcc )
  17 import RdrHsSyn         ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
  18                           extractHsTyVars
  19                         )
  20 import RnHsSyn
  21 import HsCore
  22
  23 import RnBinds          ( rnTopBinds, rnMethodBinds, renameSigs )
  24 import RnEnv            ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
  25                           lookupImplicitOccRn, addImplicitOccRn,
  26                           bindLocalsRn,
  27                           bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
  28                           checkDupOrQualNames, checkDupNames,
  29                           newLocallyDefinedGlobalName, newImportedGlobalName,
  30                           newImportedGlobalFromRdrName,
  31                           newDFunName,
  32                           FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV
  33                         )
  34 import RnMonad
  35
  36 import Name             ( Name, OccName,
  37                           ExportFlag(..), Provenance(..),
  38                           nameOccName, NamedThing(..),
  39                           mkDefaultMethodOcc, mkDFunOcc
  40                         )
  41 import NameSet
  42 import BasicTypes       ( TopLevelFlag(..) )
  43 import TysWiredIn       ( tupleTyCon, unboxedTupleTyCon, listTyCon )
  44 import Type             ( funTyCon )
  45 import FiniteMap        ( elemFM )
  46 import PrelInfo         ( derivingOccurrences, numClass_RDR,
  47                           deRefStablePtr_NAME, makeStablePtr_NAME,
  48                           bindIO_NAME
  49                         )
  50 import Bag              ( bagToList )
  51 import Outputable
  52 import SrcLoc           ( SrcLoc )
  53 import UniqFM           ( lookupUFM )
  54 import Maybes           ( maybeToBool )
  55 import Util
  56 \end{code}
  57
  58 rnDecl `renames' declarations.
  59 It simultaneously performs dependency analysis and precedence parsing.
  60 It also does the following error checks:
  61 \begin{enumerate}
  62 \item
  63 Checks that tyvars are used properly. This includes checking
  64 for undefined tyvars, and tyvars in contexts that are ambiguous.
  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 :: [RdrNameHsDecl] -> RnMS s ([RenamedHsDecl], FreeVars)
  80         -- The decls get reversed, but that's ok
  81
  82 rnSourceDecls decls
  83   = go emptyFVs [] decls
  84   where
  85         -- Fixity decls have been dealt with already; ignore them
  86     go fvs ds' []          = returnRn (ds', fvs)
  87     go fvs ds' (FixD _:ds) = go fvs ds' ds
  88     go fvs ds' (d:ds)      = rnDecl d   `thenRn` \(d', fvs') ->
  89                              go (fvs `plusFV` fvs') (d':ds') ds
  90
  91 rnIfaceDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
  92 rnIfaceDecl d
  93   = rnDecl d    `thenRn` \ (d', fvs) ->
  94     returnRn d'
  95 \end{code}
  96
  97
  98 %*********************************************************
  99 %*                                                      *
 100 \subsection{Value declarations}
 101 %*                                                      *
 102 %*********************************************************
 103
 104 \begin{code}
 105 -- rnDecl does all the work
 106 rnDecl :: RdrNameHsDecl -> RnMS s (RenamedHsDecl, FreeVars)
 107
 108 rnDecl (ValD binds) = rnTopBinds binds  `thenRn` \ (new_binds, fvs) ->
 109                       returnRn (ValD new_binds, fvs)
 110
 111
 112 rnDecl (SigD (IfaceSig name ty id_infos loc))
 113   = pushSrcLocRn loc $
 114     lookupBndrRn name           `thenRn` \ name' ->
 115     rnIfaceType doc_str ty      `thenRn` \ ty' ->
 116
 117         -- Get the pragma info (if any).
 118     setModeRn (InterfaceMode Optional)          $
 119         -- In all the rest of the signature we read in optional mode,
 120         -- so that (a) we don't die
 121     mapRn rnIdInfo id_infos     `thenRn` \ id_infos' ->
 122     returnRn (SigD (IfaceSig name' ty' id_infos' loc), emptyFVs)
 123                 -- Don't need free-var info for iface binds
 124   where
 125     doc_str = text "the interface signature for" <+> quotes (ppr name)
 126 \end{code}
 127
 128 %*********************************************************
 129 %*                                                      *
 130 \subsection{Type declarations}
 131 %*                                                      *
 132 %*********************************************************
 133
 134 @rnTyDecl@ uses the `global name function' to create a new type
 135 declaration in which local names have been replaced by their original
 136 names, reporting any unknown names.
 137
 138 Renaming type variables is a pain. Because they now contain uniques,
 139 it is necessary to pass in an association list which maps a parsed
 140 tyvar to its Name representation. In some cases (type signatures of
 141 values), it is even necessary to go over the type first in order to
 142 get the set of tyvars used by it, make an assoc list, and then go over
 143 it again to rename the tyvars! However, we can also do some scoping
 144 checks at the same time.
 145
 146 \begin{code}
 147 rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls 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     mapAndUnzipRn rnConDecl condecls                    `thenRn` \ (condecls', con_fvs_s) ->
 154     rnDerivs derivings                                  `thenRn` \ (derivings', deriv_fvs) ->
 155     ASSERT(isNoDataPragmas pragmas)
 156     returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc),
 157               cxt_fvs `plusFV` plusFVs con_fvs_s `plusFV` deriv_fvs)
 158   where
 159     data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
 160     con_names = map conDeclName condecls
 161
 162 rnDecl (TyClD (TySynonym name tyvars ty src_loc))
 163   = pushSrcLocRn src_loc $
 164     lookupBndrRn name                           `thenRn` \ name' ->
 165     bindTyVarsFVRn syn_doc tyvars               $ \ tyvars' ->
 166     rnHsType syn_doc ty                         `thenRn` \ (ty', ty_fvs) ->
 167     returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
 168   where
 169     syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 170
 171 rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_loc))
 172   = pushSrcLocRn src_loc $
 173
 174     lookupBndrRn cname                                  `thenRn` \ cname' ->
 175
 176         -- Deal with the implicit tycon and datacon name
 177         -- They aren't in scope (because they aren't visible to the user)
 178         -- and what we want to do is simply look them up in the cache;
 179         -- we jolly well ought to get a 'hit' there!
 180         -- So the 'Imported' part of this call is not relevant.
 181         -- Unclean; but since these two are the only place this happens
 182         -- I can't work up the energy to do it more beautifully
 183     newImportedGlobalFromRdrName tname                  `thenRn` \ tname' ->
 184     newImportedGlobalFromRdrName dname                  `thenRn` \ dname' ->
 185
 186         -- Tyvars scope over bindings and context
 187     bindTyVarsFV2Rn cls_doc tyvars                      ( \ clas_tyvar_names tyvars' ->
 188
 189         -- Check the superclasses
 190     rnContext cls_doc context                           `thenRn` \ (context', cxt_fvs) ->
 191
 192         -- Check the signatures
 193     let
 194                 -- Filter out fixity signatures;
 195                 -- they are done at top level
 196           nofix_sigs = nonFixitySigs sigs
 197     in
 198     checkDupOrQualNames sig_doc sig_rdr_names_w_locs            `thenRn_`
 199     mapAndUnzipRn (rn_op cname' clas_tyvar_names) nofix_sigs    `thenRn` \ (sigs', sig_fvs_s) ->
 200
 201         -- Check the methods
 202     checkDupOrQualNames meth_doc meth_rdr_names_w_locs  `thenRn_`
 203     rnMethodBinds mbinds                                `thenRn` \ (mbinds', meth_fvs) ->
 204
 205         -- Typechecker is responsible for checking that we only
 206         -- give default-method bindings for things in this class.
 207         -- The renamer *could* check this for class decls, but can't
 208         -- for instance decls.
 209
 210     ASSERT(isNoClassPragmas pragmas)
 211     returnRn (TyClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' src_loc),
 212               plusFVs sig_fvs_s `plusFV` cxt_fvs `plusFV` meth_fvs)
 213     )
 214   where
 215     cls_doc  = text "the declaration for class"         <+> ppr cname
 216     sig_doc  = text "the signatures for class"          <+> ppr cname
 217     meth_doc = text "the default-methods for class"     <+> ppr cname
 218
 219     sig_rdr_names_w_locs  = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
 220     meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
 221     meth_rdr_names        = map fst meth_rdr_names_w_locs
 222
 223     rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn)
 224       = pushSrcLocRn locn $
 225         lookupBndrRn op                         `thenRn` \ op_name ->
 226
 227                 -- Check the signature
 228         rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
 229         let
 230             check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
 231                                                 (classTyVarNotInOpTyErr clas_tyvar sig)
 232         in
 233         mapRn check_in_op_ty clas_tyvars                 `thenRn_`
 234
 235                 -- Make the default-method name
 236         let
 237             dm_occ = mkDefaultMethodOcc (rdrNameOcc op)
 238         in
 239         getModuleRn                     `thenRn` \ mod_name ->
 240         getModeRn                       `thenRn` \ mode ->
 241         (case (mode, maybe_dm) of
 242             (SourceMode, _) | op `elem` meth_rdr_names
 243                 ->      -- There's an explicit method decl
 244                    newLocallyDefinedGlobalName mod_name dm_occ
 245                                                (\_ -> Exported) locn    `thenRn` \ dm_name ->
 246                    returnRn (Just dm_name)
 247
 248             (InterfaceMode _, Just _)
 249                 ->      -- Imported class that has a default method decl
 250                     newImportedGlobalName mod_name dm_occ       `thenRn` \ dm_name ->
 251                     addOccurrenceName dm_name                   `thenRn_`
 252                     returnRn (Just dm_name)
 253
 254             other -> returnRn Nothing
 255         )                                       `thenRn` \ maybe_dm_name ->
 256
 257
 258         returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs)
 259 \end{code}
 260
 261
 262 %*********************************************************
 263 %*                                                      *
 264 \subsection{Instance declarations}
 265 %*                                                      *
 266 %*********************************************************
 267
 268 \begin{code}
 269 rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
 270   = pushSrcLocRn src_loc $
 271     rnHsSigType (text "an instance decl") inst_ty       `thenRn` \ (inst_ty', inst_fvs) ->
 272     let
 273         inst_tyvars = case inst_ty' of
 274                         HsForAllTy inst_tyvars _ _ -> inst_tyvars
 275                         other                      -> []
 276         -- (Slightly strangely) the forall-d tyvars scope over
 277         -- the method bindings too
 278     in
 279     extendTyVarEnvFVRn inst_tyvars              $
 280
 281         -- Rename the bindings
 282         -- NB meth_names can be qualified!
 283     checkDupNames meth_doc meth_names           `thenRn_`
 284     rnMethodBinds mbinds                        `thenRn` \ (mbinds', meth_fvs) ->
 285     let
 286         binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
 287     in
 288     renameSigs NotTopLevel True binders uprags  `thenRn` \ (new_uprags, prag_fvs) ->
 289     mkDFunName inst_ty' maybe_dfun src_loc      `thenRn` \ dfun_name ->
 290     addOccurrenceName dfun_name                 `thenRn_`
 291                         -- The dfun is not optional, because we use its version number
 292                         -- to identify the version of the instance declaration
 293
 294         -- The typechecker checks that all the bindings are for the right class.
 295     returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc),
 296               inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs)
 297   where
 298     meth_doc = text "the bindings in an instance declaration"
 299     meth_names   = bagToList (collectMonoBinders mbinds)
 300 \end{code}
 301
 302 %*********************************************************
 303 %*                                                      *
 304 \subsection{Default declarations}
 305 %*                                                      *
 306 %*********************************************************
 307
 308 \begin{code}
 309 rnDecl (DefD (DefaultDecl tys src_loc))
 310   = pushSrcLocRn src_loc $
 311     rnHsTypes doc_str tys               `thenRn` \ (tys', fvs) ->
 312     lookupImplicitOccRn numClass_RDR    `thenRn_`
 313     returnRn (DefD (DefaultDecl tys' src_loc), fvs)
 314   where
 315     doc_str = text "a `default' declaration"
 316 \end{code}
 317
 318 %*********************************************************
 319 %*                                                      *
 320 \subsection{Foreign declarations}
 321 %*                                                      *
 322 %*********************************************************
 323
 324 \begin{code}
 325 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
 326   = pushSrcLocRn src_loc $
 327     lookupBndrRn name                   `thenRn` \ name' ->
 328     (case imp_exp of
 329         FoImport _ | not isDyn -> addImplicitOccRn name'
 330         FoLabel    -> addImplicitOccRn name'
 331         FoExport   | isDyn ->
 332            addImplicitOccRn makeStablePtr_NAME  `thenRn_`
 333            addImplicitOccRn deRefStablePtr_NAME `thenRn_`
 334            addImplicitOccRn bindIO_NAME         `thenRn_`
 335            returnRn name'
 336         _ -> returnRn name')            `thenRn_`
 337     rnHsSigType fo_decl_msg ty          `thenRn` \ (ty', fvs) ->
 338     returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), fvs)
 339  where
 340   fo_decl_msg = ptext SLIT("a foreign declaration")
 341   isDyn       = isDynamic ext_nm
 342
 343 \end{code}
 344
 345 %*********************************************************
 346 %*                                                      *
 347 \subsection{Support code for type/data declarations}
 348 %*                                                      *
 349 %*********************************************************
 350
 351 \begin{code}
 352 rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name], FreeVars)
 353
 354 rnDerivs Nothing -- derivs not specified
 355   = returnRn (Nothing, emptyFVs)
 356
 357 rnDerivs (Just ds)
 358   = mapRn rn_deriv ds `thenRn` \ derivs ->
 359     returnRn (Just derivs, foldl addOneFV emptyFVs derivs)
 360   where
 361     rn_deriv clas
 362       = lookupOccRn clas            `thenRn` \ clas_name ->
 363
 364                 -- Now add extra "occurrences" for things that
 365                 -- the deriving mechanism will later need in order to
 366                 -- generate code for this class.
 367         case lookupUFM derivingOccurrences clas_name of
 368                 Nothing -> addErrRn (derivingNonStdClassErr clas_name)  `thenRn_`
 369                            returnRn clas_name
 370
 371                 Just occs -> mapRn lookupImplicitOccRn occs     `thenRn_`
 372                              returnRn clas_name
 373
 374 \end{code}
 375
 376 \begin{code}
 377 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 378 conDeclName (ConDecl n _ _ _ l) = (n,l)
 379
 380 rnConDecl :: RdrNameConDecl -> RnMS s (RenamedConDecl, FreeVars)
 381 rnConDecl (ConDecl name tvs cxt details locn)
 382   = pushSrcLocRn locn $
 383     checkConName name                   `thenRn_`
 384     lookupBndrRn name                   `thenRn` \ new_name ->
 385     bindTyVarsFVRn doc tvs              $ \ new_tyvars ->
 386     rnContext doc cxt                   `thenRn` \ (new_context, cxt_fvs) ->
 387     rnConDetails doc locn details       `thenRn` \ (new_details, det_fvs) ->
 388     returnRn (ConDecl new_name new_tyvars new_context new_details locn,
 389               cxt_fvs `plusFV` det_fvs)
 390   where
 391     doc = text "the definition of data constructor" <+> quotes (ppr name)
 392
 393 rnConDetails doc locn (VanillaCon tys)
 394   = mapAndUnzipRn (rnBangTy doc) tys    `thenRn` \ (new_tys, fvs_s)  ->
 395     returnRn (VanillaCon new_tys, plusFVs fvs_s)
 396
 397 rnConDetails doc locn (InfixCon ty1 ty2)
 398   = rnBangTy doc ty1            `thenRn` \ (new_ty1, fvs1) ->
 399     rnBangTy doc ty2            `thenRn` \ (new_ty2, fvs2) ->
 400     returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
 401
 402 rnConDetails doc locn (NewCon ty mb_field)
 403   = rnHsType doc ty                     `thenRn` \ (new_ty, fvs) ->
 404     rn_field mb_field                   `thenRn` \ new_mb_field  ->
 405     returnRn (NewCon new_ty new_mb_field, fvs)
 406   where
 407     rn_field Nothing  = returnRn Nothing
 408     rn_field (Just f) =
 409        lookupBndrRn f       `thenRn` \ new_f ->
 410        returnRn (Just new_f)
 411
 412 rnConDetails doc locn (RecCon fields)
 413   = checkDupOrQualNames doc field_names `thenRn_`
 414     mapAndUnzipRn (rnField doc) fields  `thenRn` \ (new_fields, fvs_s) ->
 415     returnRn (RecCon new_fields, plusFVs fvs_s)
 416   where
 417     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 418
 419 rnField doc (names, ty)
 420   = mapRn lookupBndrRn names    `thenRn` \ new_names ->
 421     rnBangTy doc ty             `thenRn` \ (new_ty, fvs) ->
 422     returnRn ((new_names, new_ty), fvs)
 423
 424 rnBangTy doc (Banged ty)
 425   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 426     returnRn (Banged new_ty, fvs)
 427
 428 rnBangTy doc (Unbanged ty)
 429   = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
 430     returnRn (Unbanged new_ty, fvs)
 431
 432 -- This data decl will parse OK
 433 --      data T = a Int
 434 -- treating "a" as the constructor.
 435 -- It is really hard to make the parser spot this malformation.
 436 -- So the renamer has to check that the constructor is legal
 437 --
 438 -- We can get an operator as the constructor, even in the prefix form:
 439 --      data T = :% Int Int
 440 -- from interface files, which always print in prefix form
 441
 442 checkConName name
 443   = checkRn (isRdrDataCon name)
 444             (badDataCon name)
 445 \end{code}
 446
 447
 448 %*********************************************************
 449 %*                                                      *
 450 \subsection{Naming a dfun}
 451 %*                                                      *
 452 %*********************************************************
 453
 454 Make a name for the dict fun for an instance decl
 455
 456 \begin{code}
 457 mkDFunName :: RenamedHsType     -- Instance type
 458             -> Maybe RdrName    -- Dfun thing from decl; Nothing <=> source
 459             -> SrcLoc
 460             -> RnMS s Name
 461
 462 mkDFunName inst_ty maybe_df src_loc
 463   = newDFunName cl_occ tycon_occ maybe_df src_loc
 464   where
 465     (cl_occ, tycon_occ) = get_key inst_ty
 466
 467     get_key (HsForAllTy _ _ ty)     = get_key ty
 468     get_key (MonoFunTy _ ty)        = get_key ty
 469     get_key (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty)
 470
 471     get_tycon_key (MonoTyVar tv)   = nameOccName (getName tv)
 472     get_tycon_key (MonoTyApp ty _) = get_tycon_key ty
 473     get_tycon_key (MonoTupleTy tys True)  = getOccName (tupleTyCon        (length tys))
 474     get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys))
 475     get_tycon_key (MonoListTy _)   = getOccName listTyCon
 476     get_tycon_key (MonoFunTy _ _)  = getOccName funTyCon
 477 \end{code}
 478
 479
 480 %*********************************************************
 481 %*                                                      *
 482 \subsection{Support code to rename types}
 483 %*                                                      *
 484 %*********************************************************
 485
 486 \begin{code}
 487 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars)
 488         -- rnHsSigType is used for source-language type signatures,
 489         -- which use *implicit* universal quantification.
 490 rnHsSigType doc_str ty
 491   = rnHsType (text "the type signature for" <+> doc_str) ty
 492
 493 rnIfaceType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType
 494 rnIfaceType doc ty
 495  = rnHsType doc ty      `thenRn` \ (ty,_) ->
 496    returnRn ty
 497
 498 rnHsType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars)
 499
 500 rnHsType doc (HsForAllTy [] ctxt ty)
 501         -- From source code (no kinds on tyvars)
 502
 503         -- Given the signature  C => T  we universally quantify
 504         -- over FV(T) \ {in-scope-tyvars}
 505         --
 506         -- We insist that the universally quantified type vars is a superset of FV(C)
 507         -- It follows that FV(T) is a superset of FV(C), so that the context constrains
 508         -- no type variables that don't appear free in the tau-type part.
 509
 510   = getLocalNameEnv             `thenRn` \ name_env ->
 511     let
 512         mentioned_tyvars = extractHsTyVars ty
 513         forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_tyvars
 514
 515         ctxt_w_ftvs :: [((RdrName,[RdrNameHsType]), [RdrName])]
 516         ctxt_w_ftvs  = [ (constraint, foldr ((++) . extractHsTyVars) [] tys)
 517                        | constraint@(_,tys) <- ctxt]
 518
 519         -- A 'non-poly constraint' is one that does not mention *any*
 520         -- of the forall'd type variables
 521         non_poly_constraints = filter non_poly ctxt_w_ftvs
 522         non_poly (c,ftvs)    = not (any (`elem` forall_tyvars) ftvs)
 523
 524         -- A 'non-mentioned' constraint is one that mentions a
 525         -- type variable that does not appear in 'ty'
 526         non_mentioned_constraints = filter non_mentioned ctxt_w_ftvs
 527         non_mentioned (c,ftvs)    = any (not . (`elem` mentioned_tyvars)) ftvs
 528
 529         -- Zap the context if there's a problem, to avoid duplicate error message.
 530         ctxt' | null non_poly_constraints && null non_mentioned_constraints = ctxt
 531               | otherwise = []
 532     in
 533     mapRn (ctxtErr1 doc forall_tyvars ty) non_poly_constraints          `thenRn_`
 534     mapRn (ctxtErr2 doc ty)               non_mentioned_constraints     `thenRn_`
 535
 536     (bindTyVarsFVRn doc (map UserTyVar forall_tyvars)   $ \ new_tyvars ->
 537     rnContext doc ctxt'                                 `thenRn` \ (new_ctxt, cxt_fvs) ->
 538     rnHsType doc ty                                     `thenRn` \ (new_ty, ty_fvs) ->
 539     returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
 540               cxt_fvs `plusFV` ty_fvs)
 541     )
 542
 543 rnHsType doc (HsForAllTy tvs ctxt ty)
 544         -- tvs are non-empty, hence must be from an interface file
 545         --      (tyvars may be kinded)
 546   = bindTyVarsFVRn doc tvs              $ \ new_tyvars ->
 547     rnContext doc ctxt                  `thenRn` \ (new_ctxt, cxt_fvs) ->
 548     rnHsType doc ty                     `thenRn` \ (new_ty, ty_fvs) ->
 549     returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
 550               cxt_fvs `plusFV` ty_fvs)
 551
 552 rnHsType doc (MonoTyVar tyvar)
 553   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 554     returnRn (MonoTyVar tyvar', unitFV tyvar')
 555
 556 rnHsType doc (MonoFunTy ty1 ty2)
 557   = rnHsType doc ty1    `thenRn` \ (ty1', fvs1) ->
 558     rnHsType doc ty2    `thenRn` \ (ty2', fvs2) ->
 559     returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
 560
 561 rnHsType doc (MonoListTy ty)
 562   = addImplicitOccRn listTyCon_name             `thenRn_`
 563     rnHsType doc ty                             `thenRn` \ (ty', fvs) ->
 564     returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
 565
 566 rnHsType doc (MonoTupleTy tys boxed)
 567   = addImplicitOccRn tup_con_name       `thenRn_`
 568     rnHsTypes doc tys                   `thenRn` \ (tys', fvs) ->
 569     returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
 570   where
 571     tup_con_name = tupleTyCon_name boxed (length tys)
 572
 573 rnHsType doc (MonoTyApp ty1 ty2)
 574   = rnHsType doc ty1            `thenRn` \ (ty1', fvs1) ->
 575     rnHsType doc ty2            `thenRn` \ (ty2', fvs2) ->
 576     returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
 577
 578 rnHsType doc (MonoDictTy clas tys)
 579   = lookupOccRn clas            `thenRn` \ clas' ->
 580     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 581     returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
 582
 583 rnHsTypes doc tys
 584   = mapAndUnzipRn (rnHsType doc) tys    `thenRn` \ (tys, fvs_s) ->
 585     returnRn (tys, plusFVs fvs_s)
 586 \end{code}
 587
 588
 589 \begin{code}
 590 rnContext :: SDoc -> RdrNameContext -> RnMS s (RenamedContext, FreeVars)
 591
 592 rnContext doc ctxt
 593   = mapAndUnzipRn rn_ctxt ctxt          `thenRn` \ (theta, fvs_s) ->
 594     let
 595         (_, dup_asserts) = removeDups cmp_assert theta
 596     in
 597         -- Check for duplicate assertions
 598         -- If this isn't an error, then it ought to be:
 599     mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts    `thenRn_`
 600
 601     returnRn (theta, plusFVs fvs_s)
 602   where
 603     rn_ctxt (clas, tys)
 604       = lookupOccRn clas                `thenRn` \ clas_name ->
 605         rnHsTypes doc tys               `thenRn` \ (tys', fvs) ->
 606         returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
 607
 608     cmp_assert (c1,tys1) (c2,tys2)
 609       = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
 610 \end{code}
 611
 612
 613 %*********************************************************
 614 %*                                                      *
 615 \subsection{IdInfo}
 616 %*                                                      *
 617 %*********************************************************
 618
 619 \begin{code}
 620 rnIdInfo (HsStrictness strict)
 621   = rnStrict strict     `thenRn` \ strict' ->
 622     returnRn (HsStrictness strict')
 623
 624 rnIdInfo (HsUnfold inline (Just expr))  = rnCoreExpr expr       `thenRn` \ expr' ->
 625                                           returnRn (HsUnfold inline (Just expr'))
 626 rnIdInfo (HsUnfold inline Nothing)      = returnRn (HsUnfold inline Nothing)
 627 rnIdInfo (HsArity arity)        = returnRn (HsArity arity)
 628 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update)
 629 rnIdInfo (HsNoCafRefs)          = returnRn (HsNoCafRefs)
 630 rnIdInfo (HsSpecialise tyvars tys expr)
 631   = bindTyVarsRn doc tyvars     $ \ tyvars' ->
 632     rnCoreExpr expr             `thenRn` \ expr' ->
 633     mapRn (rnIfaceType doc) tys `thenRn` \ tys' ->
 634     returnRn (HsSpecialise tyvars' tys' expr')
 635   where
 636     doc = text "Specialise in interface pragma"
 637
 638
 639 rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
 640         -- The sole purpose of the "cons" field is so that we can mark the constructors
 641         -- needed to build the wrapper as "needed", so that their data type decl will be
 642         -- slurped in. After that their usefulness is o'er, so we just put in the empty list.
 643   = lookupOccRn worker                  `thenRn` \ worker' ->
 644     mapRn lookupOccRn cons              `thenRn_`
 645     returnRn (HsStrictnessInfo demands (Just (worker',[])))
 646
 647 -- Boring, but necessary for the type checker.
 648 rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing)
 649 rnStrict HsBottom                         = returnRn HsBottom
 650 \end{code}
 651
 652 UfCore expressions.
 653
 654 \begin{code}
 655 rnCoreExpr (UfType ty)
 656   = rnIfaceType (text "unfolding type") ty      `thenRn` \ ty' ->
 657     returnRn (UfType ty')
 658
 659 rnCoreExpr (UfVar v)
 660   = lookupOccRn v       `thenRn` \ v' ->
 661     returnRn (UfVar v')
 662
 663 rnCoreExpr (UfCon con args)
 664   = rnUfCon con                 `thenRn` \ con' ->
 665     mapRn rnCoreExpr args       `thenRn` \ args' ->
 666     returnRn (UfCon con' args')
 667
 668 rnCoreExpr (UfTuple con args)
 669   = lookupOccRn con             `thenRn` \ con' ->
 670     mapRn rnCoreExpr args       `thenRn` \ args' ->
 671     returnRn (UfTuple con' args')
 672
 673 rnCoreExpr (UfApp fun arg)
 674   = rnCoreExpr fun              `thenRn` \ fun' ->
 675     rnCoreExpr arg              `thenRn` \ arg' ->
 676     returnRn (UfApp fun' arg')
 677
 678 rnCoreExpr (UfCase scrut bndr alts)
 679   = rnCoreExpr scrut                    `thenRn` \ scrut' ->
 680     bindLocalsRn "a UfCase" [bndr]      $ \ [bndr'] ->
 681     mapRn rnCoreAlt alts                `thenRn` \ alts' ->
 682     returnRn (UfCase scrut' bndr' alts')
 683
 684 rnCoreExpr (UfNote note expr)
 685   = rnNote note                 `thenRn` \ note' ->
 686     rnCoreExpr expr             `thenRn` \ expr' ->
 687     returnRn  (UfNote note' expr')
 688
 689 rnCoreExpr (UfLam bndr body)
 690   = rnCoreBndr bndr             $ \ bndr' ->
 691     rnCoreExpr body             `thenRn` \ body' ->
 692     returnRn (UfLam bndr' body')
 693
 694 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 695   = rnCoreExpr rhs              `thenRn` \ rhs' ->
 696     rnCoreBndr bndr             $ \ bndr' ->
 697     rnCoreExpr body             `thenRn` \ body' ->
 698     returnRn (UfLet (UfNonRec bndr' rhs') body')
 699
 700 rnCoreExpr (UfLet (UfRec pairs) body)
 701   = rnCoreBndrs bndrs           $ \ bndrs' ->
 702     mapRn rnCoreExpr rhss       `thenRn` \ rhss' ->
 703     rnCoreExpr body             `thenRn` \ body' ->
 704     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
 705   where
 706     (bndrs, rhss) = unzip pairs
 707 \end{code}
 708
 709 \begin{code}
 710 rnCoreBndr (UfValBinder name ty) thing_inside
 711   = rnIfaceType (text str) ty   `thenRn` \ ty' ->
 712     bindLocalsRn str [name]     $ \ [name'] ->
 713     thing_inside (UfValBinder name' ty')
 714   where
 715     str = "unfolding id"
 716
 717 rnCoreBndr (UfTyBinder name kind) thing_inside
 718   = bindLocalsRn "an unfolding tyvar" [name] $ \ [name'] ->
 719     thing_inside (UfTyBinder name' kind)
 720
 721 rnCoreBndrs bndrs thing_inside          -- Expect them all to be ValBinders
 722   = mapRn (rnIfaceType (text str)) tys  `thenRn` \ tys' ->
 723     bindLocalsRn str names              $ \ names' ->
 724     thing_inside (zipWith UfValBinder names' tys')
 725   where
 726     str   = "unfolding id"
 727     names = map (\ (UfValBinder name _ ) -> name) bndrs
 728     tys   = map (\ (UfValBinder _    ty) -> ty)   bndrs
 729 \end{code}
 730
 731 \begin{code}
 732 rnCoreAlt (con, bndrs, rhs)
 733   = rnUfCon con                                 `thenRn` \ con' ->
 734     bindLocalsRn "an unfolding alt" bndrs       $ \ bndrs' ->
 735     rnCoreExpr rhs                              `thenRn` \ rhs' ->
 736     returnRn (con', bndrs', rhs')
 737
 738
 739 rnNote (UfCoerce ty)
 740   = rnIfaceType (text "unfolding coerce") ty    `thenRn` \ ty' ->
 741     returnRn (UfCoerce ty')
 742
 743 rnNote (UfSCC cc)   = returnRn (UfSCC cc)
 744 rnNote UfInlineCall = returnRn UfInlineCall
 745
 746
 747 rnUfCon UfDefault
 748   = returnRn UfDefault
 749
 750 rnUfCon (UfDataCon con)
 751   = lookupOccRn con             `thenRn` \ con' ->
 752     returnRn (UfDataCon con')
 753
 754 rnUfCon (UfLitCon lit)
 755   = returnRn (UfLitCon lit)
 756
 757 rnUfCon (UfLitLitCon lit ty)
 758   = rnIfaceType (text "litlit") ty              `thenRn` \ ty' ->
 759     returnRn (UfLitLitCon lit ty')
 760
 761 rnUfCon (UfPrimOp op)
 762   = lookupOccRn op              `thenRn` \ op' ->
 763     returnRn (UfPrimOp op')
 764
 765 rnUfCon (UfCCallOp str is_dyn casm gc)
 766   = returnRn (UfCCallOp str is_dyn casm gc)
 767 \end{code}
 768
 769 %*********************************************************
 770 %*                                                      *
 771 \subsection{Errors}
 772 %*                                                      *
 773 %*********************************************************
 774
 775 \begin{code}
 776 derivingNonStdClassErr clas
 777   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 778
 779 classTyVarNotInOpTyErr clas_tyvar sig
 780   = hang (hsep [ptext SLIT("Class type variable"),
 781                        quotes (ppr clas_tyvar),
 782                        ptext SLIT("does not appear in method signature")])
 783          4 (ppr sig)
 784
 785 dupClassAssertWarn ctxt (assertion : dups)
 786   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 787                quotes (pprClassAssertion assertion),
 788                ptext SLIT("in the context:")],
 789          nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
 790
 791 badDataCon name
 792    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 793
 794 ctxtErr1 doc tyvars ty (constraint, _)
 795   = addErrRn (
 796       sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
 797                    ptext SLIT("does not mention any of"),
 798            nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars)),
 799            nest 4 (ptext SLIT("of the type") <+> quotes (ppr ty))
 800       ]
 801       $$
 802       (ptext SLIT("In") <+> doc)
 803     )
 804
 805 ctxtErr2 doc ty (constraint,_)
 806   = addErrRn (
 807         sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint),
 808         nest 4 (ptext SLIT("mentions type variables that do not appear in the type")),
 809         nest 4 (quotes (ppr ty))]
 810         $$
 811         (ptext SLIT("In") <+> doc)
 812     )
 813 \end{code}