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, unknownSigErr )
  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             -- First process the class op sigs, then the fixity sigs.
 197           (op_sigs, non_op_sigs) = partition isClassOpSig sigs
 198           (fix_sigs, non_sigs)   = partition isFixitySig  non_op_sigs
 199     in
 200     checkDupOrQualNames sig_doc sig_rdr_names_w_locs      `thenRn_`
 201     mapAndUnzipRn (rn_op cname' clas_tyvar_names) op_sigs `thenRn` \ (sigs', sig_fvs_s) ->
 202     mapRn_  (unknownSigErr) non_sigs                      `thenRn_`
 203     let
 204      binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
 205     in
 206     renameSigs False binders lookupOccRn fix_sigs         `thenRn` \ (fixs', fix_fvs) ->
 207
 208         -- Check the methods
 209     checkDupOrQualNames meth_doc meth_rdr_names_w_locs  `thenRn_`
 210     rnMethodBinds mbinds                                `thenRn` \ (mbinds', meth_fvs) ->
 211
 212         -- Typechecker is responsible for checking that we only
 213         -- give default-method bindings for things in this class.
 214         -- The renamer *could* check this for class decls, but can't
 215         -- for instance decls.
 216
 217     ASSERT(isNoClassPragmas pragmas)
 218     returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') mbinds' NoClassPragmas tname' dname' src_loc),
 219               plusFVs sig_fvs_s `plusFV`
 220               fix_fvs           `plusFV`
 221               cxt_fvs           `plusFV`
 222               meth_fvs
 223              )
 224     )
 225   where
 226     cls_doc  = text "the declaration for class"         <+> ppr cname
 227     sig_doc  = text "the signatures for class"          <+> ppr cname
 228     meth_doc = text "the default-methods for class"     <+> ppr cname
 229
 230     sig_rdr_names_w_locs  = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
 231     meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
 232     meth_rdr_names        = map fst meth_rdr_names_w_locs
 233
 234     rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn)
 235       = pushSrcLocRn locn $
 236         lookupBndrRn op                         `thenRn` \ op_name ->
 237
 238                 -- Check the signature
 239         rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
 240         let
 241             check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
 242                                                 (classTyVarNotInOpTyErr clas_tyvar sig)
 243         in
 244         mapRn_ check_in_op_ty clas_tyvars                `thenRn_`
 245
 246                 -- Make the default-method name
 247         let
 248             dm_occ = mkDefaultMethodOcc (rdrNameOcc op)
 249         in
 250         getModuleRn                     `thenRn` \ mod_name ->
 251         getModeRn                       `thenRn` \ mode ->
 252         (case (mode, maybe_dm) of
 253             (SourceMode, _) | op `elem` meth_rdr_names
 254                 ->      -- There's an explicit method decl
 255                    newLocallyDefinedGlobalName mod_name dm_occ
 256                                                (\_ -> Exported) locn    `thenRn` \ dm_name ->
 257                    returnRn (Just dm_name)
 258
 259             (InterfaceMode _, Just _)
 260                 ->      -- Imported class that has a default method decl
 261                     newImportedGlobalName mod_name dm_occ       `thenRn` \ dm_name ->
 262                     addOccurrenceName dm_name                   `thenRn_`
 263                     returnRn (Just dm_name)
 264
 265             other -> returnRn Nothing
 266         )                                       `thenRn` \ maybe_dm_name ->
 267
 268
 269         returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs)
 270 \end{code}
 271
 272
 273 %*********************************************************
 274 %*                                                      *
 275 \subsection{Instance declarations}
 276 %*                                                      *
 277 %*********************************************************
 278
 279 \begin{code}
 280 rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
 281   = pushSrcLocRn src_loc $
 282     rnHsSigType (text "an instance decl") inst_ty       `thenRn` \ (inst_ty', inst_fvs) ->
 283     let
 284         inst_tyvars = case inst_ty' of
 285                         HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
 286                         other                             -> []
 287         -- (Slightly strangely) the forall-d tyvars scope over
 288         -- the method bindings too
 289     in
 290     extendTyVarEnvFVRn inst_tyvars              $
 291
 292         -- Rename the bindings
 293         -- NB meth_names can be qualified!
 294     checkDupNames meth_doc meth_names           `thenRn_`
 295     rnMethodBinds mbinds                        `thenRn` \ (mbinds', meth_fvs) ->
 296     let
 297         binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
 298
 299         -- Delete sigs (&report) sigs that aren't allowed inside an
 300         -- instance decl:
 301         --
 302         --  + type signatures
 303         --  + fixity decls
 304         --
 305         (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
 306
 307         okInInstDecl (FixSig _)  = False
 308         okInInstDecl (Sig _ _ _) = False
 309         okInInstDecl _           = True
 310
 311     in
 312       -- You can't have fixity decls & type signatures
 313       -- within an instance declaration.
 314     mapRn_ unknownSigErr not_ok_idecl_sigs       `thenRn_`
 315     renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
 316     mkDFunName inst_ty' maybe_dfun src_loc       `thenRn` \ dfun_name ->
 317     addOccurrenceName dfun_name                  `thenRn_`
 318                         -- The dfun is not optional, because we use its version number
 319                         -- to identify the version of the instance declaration
 320
 321         -- The typechecker checks that all the bindings are for the right class.
 322     returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc),
 323               inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs)
 324   where
 325     meth_doc = text "the bindings in an instance declaration"
 326     meth_names   = bagToList (collectMonoBinders mbinds)
 327 \end{code}
 328
 329 %*********************************************************
 330 %*                                                      *
 331 \subsection{Default declarations}
 332 %*                                                      *
 333 %*********************************************************
 334
 335 \begin{code}
 336 rnDecl (DefD (DefaultDecl tys src_loc))
 337   = pushSrcLocRn src_loc $
 338     rnHsTypes doc_str tys               `thenRn` \ (tys', fvs) ->
 339     lookupImplicitOccRn numClass_RDR    `thenRn_`
 340     returnRn (DefD (DefaultDecl tys' src_loc), fvs)
 341   where
 342     doc_str = text "a `default' declaration"
 343 \end{code}
 344
 345 %*********************************************************
 346 %*                                                      *
 347 \subsection{Foreign declarations}
 348 %*                                                      *
 349 %*********************************************************
 350
 351 \begin{code}
 352 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
 353   = pushSrcLocRn src_loc $
 354     lookupBndrRn name                   `thenRn` \ name' ->
 355     (case imp_exp of
 356         FoImport _ | not isDyn -> addImplicitOccRn name'
 357         FoLabel    -> addImplicitOccRn name'
 358         FoExport   | isDyn ->
 359            addImplicitOccRn makeStablePtr_NAME  `thenRn_`
 360            addImplicitOccRn deRefStablePtr_NAME `thenRn_`
 361            addImplicitOccRn bindIO_NAME         `thenRn_`
 362            returnRn name'
 363         _ -> returnRn name')                    `thenRn_`
 364     rnHsSigType fo_decl_msg ty                  `thenRn` \ (ty', fvs) ->
 365     returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), fvs)
 366  where
 367   fo_decl_msg = ptext SLIT("a foreign declaration")
 368   isDyn       = isDynamic ext_nm
 369
 370 \end{code}
 371
 372 %*********************************************************
 373 %*                                                      *
 374 \subsection{Support code for type/data declarations}
 375 %*                                                      *
 376 %*********************************************************
 377
 378 \begin{code}
 379 rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name], FreeVars)
 380
 381 rnDerivs Nothing -- derivs not specified
 382   = returnRn (Nothing, emptyFVs)
 383
 384 rnDerivs (Just ds)
 385   = mapRn rn_deriv ds `thenRn` \ derivs ->
 386     returnRn (Just derivs, foldl addOneFV emptyFVs derivs)
 387   where
 388     rn_deriv clas
 389       = lookupOccRn clas            `thenRn` \ clas_name ->
 390
 391                 -- Now add extra "occurrences" for things that
 392                 -- the deriving mechanism will later need in order to
 393                 -- generate code for this class.
 394         case lookupUFM derivingOccurrences clas_name of
 395                 Nothing -> addErrRn (derivingNonStdClassErr clas_name)  `thenRn_`
 396                            returnRn clas_name
 397
 398                 Just occs -> mapRn_ lookupImplicitOccRn occs    `thenRn_`
 399                              returnRn clas_name
 400
 401 \end{code}
 402
 403 \begin{code}
 404 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 405 conDeclName (ConDecl n _ _ _ l) = (n,l)
 406
 407 rnConDecl :: RdrNameConDecl -> RnMS s (RenamedConDecl, FreeVars)
 408 rnConDecl (ConDecl name tvs cxt details locn)
 409   = pushSrcLocRn locn $
 410     checkConName name                   `thenRn_`
 411     lookupBndrRn name                   `thenRn` \ new_name ->
 412     bindTyVarsFVRn doc tvs              $ \ new_tyvars ->
 413     rnContext doc cxt                   `thenRn` \ (new_context, cxt_fvs) ->
 414     rnConDetails doc locn details       `thenRn` \ (new_details, det_fvs) ->
 415     returnRn (ConDecl new_name new_tyvars new_context new_details locn,
 416               cxt_fvs `plusFV` det_fvs)
 417   where
 418     doc = text "the definition of data constructor" <+> quotes (ppr name)
 419
 420 rnConDetails doc locn (VanillaCon tys)
 421   = mapAndUnzipRn (rnBangTy doc) tys    `thenRn` \ (new_tys, fvs_s)  ->
 422     returnRn (VanillaCon new_tys, plusFVs fvs_s)
 423
 424 rnConDetails doc locn (InfixCon ty1 ty2)
 425   = rnBangTy doc ty1            `thenRn` \ (new_ty1, fvs1) ->
 426     rnBangTy doc ty2            `thenRn` \ (new_ty2, fvs2) ->
 427     returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
 428
 429 rnConDetails doc locn (NewCon ty mb_field)
 430   = rnHsType doc ty                     `thenRn` \ (new_ty, fvs) ->
 431     rn_field mb_field                   `thenRn` \ new_mb_field  ->
 432     returnRn (NewCon new_ty new_mb_field, fvs)
 433   where
 434     rn_field Nothing  = returnRn Nothing
 435     rn_field (Just f) =
 436        lookupBndrRn f       `thenRn` \ new_f ->
 437        returnRn (Just new_f)
 438
 439 rnConDetails doc locn (RecCon fields)
 440   = checkDupOrQualNames doc field_names `thenRn_`
 441     mapAndUnzipRn (rnField doc) fields  `thenRn` \ (new_fields, fvs_s) ->
 442     returnRn (RecCon new_fields, plusFVs fvs_s)
 443   where
 444     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 445
 446 rnField doc (names, ty)
 447   = mapRn lookupBndrRn names    `thenRn` \ new_names ->
 448     rnBangTy doc ty             `thenRn` \ (new_ty, fvs) ->
 449     returnRn ((new_names, new_ty), fvs)
 450
 451 rnBangTy doc (Banged ty)
 452   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 453     returnRn (Banged new_ty, fvs)
 454
 455 rnBangTy doc (Unbanged ty)
 456   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 457     returnRn (Unbanged new_ty, fvs)
 458
 459 rnBangTy doc (Unpacked ty)
 460   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 461     returnRn (Unpacked new_ty, fvs)
 462
 463 -- This data decl will parse OK
 464 --      data T = a Int
 465 -- treating "a" as the constructor.
 466 -- It is really hard to make the parser spot this malformation.
 467 -- So the renamer has to check that the constructor is legal
 468 --
 469 -- We can get an operator as the constructor, even in the prefix form:
 470 --      data T = :% Int Int
 471 -- from interface files, which always print in prefix form
 472
 473 checkConName name
 474   = checkRn (isRdrDataCon name)
 475             (badDataCon name)
 476 \end{code}
 477
 478
 479 %*********************************************************
 480 %*                                                      *
 481 \subsection{Naming a dfun}
 482 %*                                                      *
 483 %*********************************************************
 484
 485 Make a name for the dict fun for an instance decl
 486
 487 \begin{code}
 488 mkDFunName :: RenamedHsType     -- Instance type
 489             -> Maybe RdrName    -- Dfun thing from decl; Nothing <=> source
 490             -> SrcLoc
 491             -> RnMS s Name
 492
 493 mkDFunName inst_ty maybe_df src_loc
 494   = newDFunName cl_occ tycon_occ maybe_df src_loc
 495   where
 496     (cl_occ, tycon_occ) = get_key inst_ty
 497
 498     get_key (HsForAllTy _ _ ty)     = get_key ty
 499     get_key (MonoFunTy _ ty)        = get_key ty
 500     get_key (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty)
 501
 502     get_tycon_key (MonoTyVar tv)   = nameOccName (getName tv)
 503     get_tycon_key (MonoTyApp ty _) = get_tycon_key ty
 504     get_tycon_key (MonoTupleTy tys True)  = getOccName (tupleTyCon        (length tys))
 505     get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys))
 506     get_tycon_key (MonoListTy _)   = getOccName listTyCon
 507     get_tycon_key (MonoFunTy _ _)  = getOccName funTyCon
 508 \end{code}
 509
 510
 511 %*********************************************************
 512 %*                                                      *
 513 \subsection{Support code to rename types}
 514 %*                                                      *
 515 %*********************************************************
 516
 517 \begin{code}
 518 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars)
 519         -- rnHsSigType is used for source-language type signatures,
 520         -- which use *implicit* universal quantification.
 521 rnHsSigType doc_str ty
 522   = rnHsType (text "the type signature for" <+> doc_str) ty
 523
 524 rnIfaceType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType
 525 rnIfaceType doc ty
 526  = rnHsType doc ty      `thenRn` \ (ty,_) ->
 527    returnRn ty
 528
 529
 530 rnForAll doc forall_tyvars ctxt ty
 531   = bindTyVarsFVRn doc forall_tyvars                    $ \ new_tyvars ->
 532     rnContext doc ctxt                                  `thenRn` \ (new_ctxt, cxt_fvs) ->
 533     rnHsType doc ty                                     `thenRn` \ (new_ty, ty_fvs) ->
 534     returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
 535               cxt_fvs `plusFV` ty_fvs)
 536
 537 -- Check that each constraint mentions at least one of the forall'd type variables
 538 -- Since the forall'd type variables are a subset of the free tyvars
 539 -- of the tau-type part, this guarantees that every constraint mentions
 540 -- at least one of the free tyvars in ty
 541 checkConstraints explicit_forall doc forall_tyvars ctxt ty
 542    = mapRn check ctxt                   `thenRn` \ maybe_ctxt' ->
 543      returnRn (catMaybes maybe_ctxt')
 544             -- Remove problem ones, to avoid duplicate error message.
 545    where
 546      check ct@(_,tys)
 547         | forall_mentioned = returnRn (Just ct)
 548         | otherwise        = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty) `thenRn_`
 549                              returnRn Nothing
 550         where
 551           forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyVars)
 552                              False
 553                              tys
 554
 555
 556 rnHsType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars)
 557
 558 rnHsType doc (HsForAllTy Nothing ctxt ty)
 559         -- From source code (no kinds on tyvars)
 560         -- Given the signature  C => T  we universally quantify
 561         -- over FV(T) \ {in-scope-tyvars}
 562   = getLocalNameEnv             `thenRn` \ name_env ->
 563     let
 564         mentioned_tyvars = extractHsTyVars ty
 565         forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_tyvars
 566     in
 567     checkConstraints False doc forall_tyvars ctxt ty    `thenRn` \ ctxt' ->
 568     rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
 569
 570 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt ty)
 571         -- Explicit quantification.
 572         -- Check that the forall'd tyvars are a subset of the
 573         -- free tyvars in the tau-type part
 574         -- That's only a warning... unless the tyvar is constrained by a
 575         -- context in which case it's an error
 576   = let
 577         mentioned_tyvars      = extractHsTyVars ty
 578         constrained_tyvars    = [tv | (_,tys) <- ctxt,
 579                                       ty <- tys,
 580                                       tv <- extractHsTyVars ty]
 581         dubious_guys          = filter (`notElem` mentioned_tyvars) forall_tyvar_names
 582         (bad_guys, warn_guys) = partition (`elem` constrained_tyvars) dubious_guys
 583         forall_tyvar_names    = map getTyVarName forall_tyvars
 584     in
 585     mapRn_ (forAllErr doc ty) bad_guys                          `thenRn_`
 586     mapRn_ (forAllWarn doc ty) warn_guys                        `thenRn_`
 587     checkConstraints True doc forall_tyvar_names ctxt ty        `thenRn` \ ctxt' ->
 588     rnForAll doc forall_tyvars ctxt' ty
 589
 590 rnHsType doc (MonoTyVar tyvar)
 591   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 592     returnRn (MonoTyVar tyvar', unitFV tyvar')
 593
 594 rnHsType doc (MonoFunTy ty1 ty2)
 595   = rnHsType doc ty1    `thenRn` \ (ty1', fvs1) ->
 596     rnHsType doc ty2    `thenRn` \ (ty2', fvs2) ->
 597     returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
 598
 599 rnHsType doc (MonoListTy ty)
 600   = addImplicitOccRn listTyCon_name             `thenRn_`
 601     rnHsType doc ty                             `thenRn` \ (ty', fvs) ->
 602     returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
 603
 604 rnHsType doc (MonoTupleTy tys boxed)
 605   = addImplicitOccRn tup_con_name       `thenRn_`
 606     rnHsTypes doc tys                   `thenRn` \ (tys', fvs) ->
 607     returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
 608   where
 609     tup_con_name = tupleTyCon_name boxed (length tys)
 610
 611 rnHsType doc (MonoTyApp ty1 ty2)
 612   = rnHsType doc ty1            `thenRn` \ (ty1', fvs1) ->
 613     rnHsType doc ty2            `thenRn` \ (ty2', fvs2) ->
 614     returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
 615
 616 rnHsType doc (MonoDictTy clas tys)
 617   = lookupOccRn clas            `thenRn` \ clas' ->
 618     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 619     returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
 620
 621 rnHsType doc (MonoUsgTy usg ty)
 622   = rnHsType doc ty             `thenRn` \ (ty', fvs) ->
 623     returnRn (MonoUsgTy usg ty', fvs)
 624
 625 rnHsTypes doc tys
 626   = mapAndUnzipRn (rnHsType doc) tys    `thenRn` \ (tys, fvs_s) ->
 627     returnRn (tys, plusFVs fvs_s)
 628 \end{code}
 629
 630
 631 \begin{code}
 632 rnContext :: SDoc -> RdrNameContext -> RnMS s (RenamedContext, FreeVars)
 633
 634 rnContext doc ctxt
 635   = mapAndUnzipRn rn_ctxt ctxt          `thenRn` \ (theta, fvs_s) ->
 636     let
 637         (_, dup_asserts) = removeDups cmp_assert theta
 638     in
 639         -- Check for duplicate assertions
 640         -- If this isn't an error, then it ought to be:
 641     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts   `thenRn_`
 642
 643     returnRn (theta, plusFVs fvs_s)
 644   where
 645     rn_ctxt (clas, tys)
 646       = lookupOccRn clas                `thenRn` \ clas_name ->
 647         rnHsTypes doc tys               `thenRn` \ (tys', fvs) ->
 648         returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
 649
 650     cmp_assert (c1,tys1) (c2,tys2)
 651       = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
 652 \end{code}
 653
 654
 655 %*********************************************************
 656 %*                                                      *
 657 \subsection{IdInfo}
 658 %*                                                      *
 659 %*********************************************************
 660
 661 \begin{code}
 662 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str)
 663
 664 rnIdInfo (HsWorker worker cons)
 665         -- The sole purpose of the "cons" field is so that we can mark the
 666         -- constructors needed to build the wrapper as "needed", so that their
 667         -- data type decl will be slurped in. After that their usefulness is
 668         -- o'er, so we just put in the empty list.
 669   = lookupOccRn worker                  `thenRn` \ worker' ->
 670     mapRn lookupOccRn cons              `thenRn_`
 671     returnRn (HsWorker worker' [])
 672
 673 rnIdInfo (HsUnfold inline (Just expr))  = rnCoreExpr expr       `thenRn` \ expr' ->
 674                                           returnRn (HsUnfold inline (Just expr'))
 675 rnIdInfo (HsUnfold inline Nothing)      = returnRn (HsUnfold inline Nothing)
 676 rnIdInfo (HsArity arity)        = returnRn (HsArity arity)
 677 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update)
 678 rnIdInfo (HsNoCafRefs)          = returnRn (HsNoCafRefs)
 679 rnIdInfo (HsCprInfo cpr_info)   = returnRn (HsCprInfo cpr_info)
 680 rnIdInfo (HsSpecialise tyvars tys expr)
 681   = bindTyVarsRn doc tyvars     $ \ tyvars' ->
 682     rnCoreExpr expr             `thenRn` \ expr' ->
 683     mapRn (rnIfaceType doc) tys `thenRn` \ tys' ->
 684     returnRn (HsSpecialise tyvars' tys' expr')
 685   where
 686     doc = text "Specialise in interface pragma"
 687 \end{code}
 688
 689 UfCore expressions.
 690
 691 \begin{code}
 692 rnCoreExpr (UfType ty)
 693   = rnIfaceType (text "unfolding type") ty      `thenRn` \ ty' ->
 694     returnRn (UfType ty')
 695
 696 rnCoreExpr (UfVar v)
 697   = lookupOccRn v       `thenRn` \ v' ->
 698     returnRn (UfVar v')
 699
 700 rnCoreExpr (UfCon con args)
 701   = rnUfCon con                 `thenRn` \ con' ->
 702     mapRn rnCoreExpr args       `thenRn` \ args' ->
 703     returnRn (UfCon con' args')
 704
 705 rnCoreExpr (UfTuple con args)
 706   = lookupOccRn con             `thenRn` \ con' ->
 707     mapRn rnCoreExpr args       `thenRn` \ args' ->
 708     returnRn (UfTuple con' args')
 709
 710 rnCoreExpr (UfApp fun arg)
 711   = rnCoreExpr fun              `thenRn` \ fun' ->
 712     rnCoreExpr arg              `thenRn` \ arg' ->
 713     returnRn (UfApp fun' arg')
 714
 715 rnCoreExpr (UfCase scrut bndr alts)
 716   = rnCoreExpr scrut                    `thenRn` \ scrut' ->
 717     bindLocalsRn "a UfCase" [bndr]      $ \ [bndr'] ->
 718     mapRn rnCoreAlt alts                `thenRn` \ alts' ->
 719     returnRn (UfCase scrut' bndr' alts')
 720
 721 rnCoreExpr (UfNote note expr)
 722   = rnNote note                 `thenRn` \ note' ->
 723     rnCoreExpr expr             `thenRn` \ expr' ->
 724     returnRn  (UfNote note' expr')
 725
 726 rnCoreExpr (UfLam bndr body)
 727   = rnCoreBndr bndr             $ \ bndr' ->
 728     rnCoreExpr body             `thenRn` \ body' ->
 729     returnRn (UfLam bndr' body')
 730
 731 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 732   = rnCoreExpr rhs              `thenRn` \ rhs' ->
 733     rnCoreBndr bndr             $ \ bndr' ->
 734     rnCoreExpr body             `thenRn` \ body' ->
 735     returnRn (UfLet (UfNonRec bndr' rhs') body')
 736
 737 rnCoreExpr (UfLet (UfRec pairs) body)
 738   = rnCoreBndrs bndrs           $ \ bndrs' ->
 739     mapRn rnCoreExpr rhss       `thenRn` \ rhss' ->
 740     rnCoreExpr body             `thenRn` \ body' ->
 741     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
 742   where
 743     (bndrs, rhss) = unzip pairs
 744 \end{code}
 745
 746 \begin{code}
 747 rnCoreBndr (UfValBinder name ty) thing_inside
 748   = rnIfaceType (text str) ty   `thenRn` \ ty' ->
 749     bindLocalsRn str [name]     $ \ [name'] ->
 750     thing_inside (UfValBinder name' ty')
 751   where
 752     str = "unfolding id"
 753
 754 rnCoreBndr (UfTyBinder name kind) thing_inside
 755   = bindLocalsRn "an unfolding tyvar" [name] $ \ [name'] ->
 756     thing_inside (UfTyBinder name' kind)
 757
 758 rnCoreBndrs bndrs thing_inside          -- Expect them all to be ValBinders
 759   = mapRn (rnIfaceType (text str)) tys  `thenRn` \ tys' ->
 760     bindLocalsRn str names              $ \ names' ->
 761     thing_inside (zipWith UfValBinder names' tys')
 762   where
 763     str   = "unfolding id"
 764     names = map (\ (UfValBinder name _ ) -> name) bndrs
 765     tys   = map (\ (UfValBinder _    ty) -> ty)   bndrs
 766 \end{code}
 767
 768 \begin{code}
 769 rnCoreAlt (con, bndrs, rhs)
 770   = rnUfCon con                                 `thenRn` \ con' ->
 771     bindLocalsRn "an unfolding alt" bndrs       $ \ bndrs' ->
 772     rnCoreExpr rhs                              `thenRn` \ rhs' ->
 773     returnRn (con', bndrs', rhs')
 774
 775
 776 rnNote (UfCoerce ty)
 777   = rnIfaceType (text "unfolding coerce") ty    `thenRn` \ ty' ->
 778     returnRn (UfCoerce ty')
 779
 780 rnNote (UfSCC cc)   = returnRn (UfSCC cc)
 781 rnNote UfInlineCall = returnRn UfInlineCall
 782
 783
 784 rnUfCon UfDefault
 785   = returnRn UfDefault
 786
 787 rnUfCon (UfDataCon con)
 788   = lookupOccRn con             `thenRn` \ con' ->
 789     returnRn (UfDataCon con')
 790
 791 rnUfCon (UfLitCon lit)
 792   = returnRn (UfLitCon lit)
 793
 794 rnUfCon (UfLitLitCon lit ty)
 795   = rnIfaceType (text "litlit") ty              `thenRn` \ ty' ->
 796     returnRn (UfLitLitCon lit ty')
 797
 798 rnUfCon (UfPrimOp op)
 799   = lookupOccRn op              `thenRn` \ op' ->
 800     returnRn (UfPrimOp op')
 801
 802 rnUfCon (UfCCallOp str is_dyn casm gc)
 803   = returnRn (UfCCallOp str is_dyn casm gc)
 804 \end{code}
 805
 806 %*********************************************************
 807 %*                                                      *
 808 \subsection{Errors}
 809 %*                                                      *
 810 %*********************************************************
 811
 812 \begin{code}
 813 derivingNonStdClassErr clas
 814   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 815
 816 classTyVarNotInOpTyErr clas_tyvar sig
 817   = hang (hsep [ptext SLIT("Class type variable"),
 818                        quotes (ppr clas_tyvar),
 819                        ptext SLIT("does not appear in method signature")])
 820          4 (ppr sig)
 821
 822 dupClassAssertWarn ctxt (assertion : dups)
 823   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 824                quotes (pprClassAssertion assertion),
 825                ptext SLIT("in the context:")],
 826          nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
 827
 828 badDataCon name
 829    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 830
 831 forAllWarn doc ty tyvar
 832   | not opt_WarnUnusedMatches = returnRn ()
 833   | otherwise
 834   = addWarnRn (
 835       sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 836            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 837       $$
 838       (ptext SLIT("In") <+> doc))
 839
 840 forAllErr doc ty tyvar
 841   = addErrRn (
 842       sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
 843            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 844       $$
 845       (ptext SLIT("In") <+> doc))
 846
 847 ctxtErr explicit_forall doc tyvars constraint ty
 848   = sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
 849                    ptext SLIT("does not mention any of"),
 850          if explicit_forall then
 851            nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars))
 852          else
 853            nest 4 (ptext SLIT("the type variables in the type") <+> quotes (ppr ty))
 854     ]
 855     $$
 856     (ptext SLIT("In") <+> doc)
 857 \end{code}