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