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