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 rnHsTypes doc tys
 622   = mapAndUnzipRn (rnHsType doc) tys    `thenRn` \ (tys, fvs_s) ->
 623     returnRn (tys, plusFVs fvs_s)
 624 \end{code}
 625
 626
 627 \begin{code}
 628 rnContext :: SDoc -> RdrNameContext -> RnMS s (RenamedContext, FreeVars)
 629
 630 rnContext doc ctxt
 631   = mapAndUnzipRn rn_ctxt ctxt          `thenRn` \ (theta, fvs_s) ->
 632     let
 633         (_, dup_asserts) = removeDups cmp_assert theta
 634     in
 635         -- Check for duplicate assertions
 636         -- If this isn't an error, then it ought to be:
 637     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts   `thenRn_`
 638
 639     returnRn (theta, plusFVs fvs_s)
 640   where
 641     rn_ctxt (clas, tys)
 642       = lookupOccRn clas                `thenRn` \ clas_name ->
 643         rnHsTypes doc tys               `thenRn` \ (tys', fvs) ->
 644         returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
 645
 646     cmp_assert (c1,tys1) (c2,tys2)
 647       = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
 648 \end{code}
 649
 650
 651 %*********************************************************
 652 %*                                                      *
 653 \subsection{IdInfo}
 654 %*                                                      *
 655 %*********************************************************
 656
 657 \begin{code}
 658 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str)
 659
 660 rnIdInfo (HsWorker worker cons)
 661         -- The sole purpose of the "cons" field is so that we can mark the
 662         -- constructors needed to build the wrapper as "needed", so that their
 663         -- data type decl will be slurped in. After that their usefulness is
 664         -- o'er, so we just put in the empty list.
 665   = lookupOccRn worker                  `thenRn` \ worker' ->
 666     mapRn lookupOccRn cons              `thenRn_`
 667     returnRn (HsWorker worker' [])
 668
 669 rnIdInfo (HsUnfold inline (Just expr))  = rnCoreExpr expr       `thenRn` \ expr' ->
 670                                           returnRn (HsUnfold inline (Just expr'))
 671 rnIdInfo (HsUnfold inline Nothing)      = returnRn (HsUnfold inline Nothing)
 672 rnIdInfo (HsArity arity)        = returnRn (HsArity arity)
 673 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update)
 674 rnIdInfo (HsNoCafRefs)          = returnRn (HsNoCafRefs)
 675 rnIdInfo (HsCprInfo cpr_info)   = returnRn (HsCprInfo cpr_info)
 676 rnIdInfo (HsSpecialise tyvars tys expr)
 677   = bindTyVarsRn doc tyvars     $ \ tyvars' ->
 678     rnCoreExpr expr             `thenRn` \ expr' ->
 679     mapRn (rnIfaceType doc) tys `thenRn` \ tys' ->
 680     returnRn (HsSpecialise tyvars' tys' expr')
 681   where
 682     doc = text "Specialise in interface pragma"
 683 \end{code}
 684
 685 UfCore expressions.
 686
 687 \begin{code}
 688 rnCoreExpr (UfType ty)
 689   = rnIfaceType (text "unfolding type") ty      `thenRn` \ ty' ->
 690     returnRn (UfType ty')
 691
 692 rnCoreExpr (UfVar v)
 693   = lookupOccRn v       `thenRn` \ v' ->
 694     returnRn (UfVar v')
 695
 696 rnCoreExpr (UfCon con args)
 697   = rnUfCon con                 `thenRn` \ con' ->
 698     mapRn rnCoreExpr args       `thenRn` \ args' ->
 699     returnRn (UfCon con' args')
 700
 701 rnCoreExpr (UfTuple con args)
 702   = lookupOccRn con             `thenRn` \ con' ->
 703     mapRn rnCoreExpr args       `thenRn` \ args' ->
 704     returnRn (UfTuple con' args')
 705
 706 rnCoreExpr (UfApp fun arg)
 707   = rnCoreExpr fun              `thenRn` \ fun' ->
 708     rnCoreExpr arg              `thenRn` \ arg' ->
 709     returnRn (UfApp fun' arg')
 710
 711 rnCoreExpr (UfCase scrut bndr alts)
 712   = rnCoreExpr scrut                    `thenRn` \ scrut' ->
 713     bindLocalsRn "a UfCase" [bndr]      $ \ [bndr'] ->
 714     mapRn rnCoreAlt alts                `thenRn` \ alts' ->
 715     returnRn (UfCase scrut' bndr' alts')
 716
 717 rnCoreExpr (UfNote note expr)
 718   = rnNote note                 `thenRn` \ note' ->
 719     rnCoreExpr expr             `thenRn` \ expr' ->
 720     returnRn  (UfNote note' expr')
 721
 722 rnCoreExpr (UfLam bndr body)
 723   = rnCoreBndr bndr             $ \ bndr' ->
 724     rnCoreExpr body             `thenRn` \ body' ->
 725     returnRn (UfLam bndr' body')
 726
 727 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 728   = rnCoreExpr rhs              `thenRn` \ rhs' ->
 729     rnCoreBndr bndr             $ \ bndr' ->
 730     rnCoreExpr body             `thenRn` \ body' ->
 731     returnRn (UfLet (UfNonRec bndr' rhs') body')
 732
 733 rnCoreExpr (UfLet (UfRec pairs) body)
 734   = rnCoreBndrs bndrs           $ \ bndrs' ->
 735     mapRn rnCoreExpr rhss       `thenRn` \ rhss' ->
 736     rnCoreExpr body             `thenRn` \ body' ->
 737     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
 738   where
 739     (bndrs, rhss) = unzip pairs
 740 \end{code}
 741
 742 \begin{code}
 743 rnCoreBndr (UfValBinder name ty) thing_inside
 744   = rnIfaceType (text str) ty   `thenRn` \ ty' ->
 745     bindLocalsRn str [name]     $ \ [name'] ->
 746     thing_inside (UfValBinder name' ty')
 747   where
 748     str = "unfolding id"
 749
 750 rnCoreBndr (UfTyBinder name kind) thing_inside
 751   = bindLocalsRn "an unfolding tyvar" [name] $ \ [name'] ->
 752     thing_inside (UfTyBinder name' kind)
 753
 754 rnCoreBndrs bndrs thing_inside          -- Expect them all to be ValBinders
 755   = mapRn (rnIfaceType (text str)) tys  `thenRn` \ tys' ->
 756     bindLocalsRn str names              $ \ names' ->
 757     thing_inside (zipWith UfValBinder names' tys')
 758   where
 759     str   = "unfolding id"
 760     names = map (\ (UfValBinder name _ ) -> name) bndrs
 761     tys   = map (\ (UfValBinder _    ty) -> ty)   bndrs
 762 \end{code}
 763
 764 \begin{code}
 765 rnCoreAlt (con, bndrs, rhs)
 766   = rnUfCon con                                 `thenRn` \ con' ->
 767     bindLocalsRn "an unfolding alt" bndrs       $ \ bndrs' ->
 768     rnCoreExpr rhs                              `thenRn` \ rhs' ->
 769     returnRn (con', bndrs', rhs')
 770
 771
 772 rnNote (UfCoerce ty)
 773   = rnIfaceType (text "unfolding coerce") ty    `thenRn` \ ty' ->
 774     returnRn (UfCoerce ty')
 775
 776 rnNote (UfSCC cc)   = returnRn (UfSCC cc)
 777 rnNote UfInlineCall = returnRn UfInlineCall
 778
 779
 780 rnUfCon UfDefault
 781   = returnRn UfDefault
 782
 783 rnUfCon (UfDataCon con)
 784   = lookupOccRn con             `thenRn` \ con' ->
 785     returnRn (UfDataCon con')
 786
 787 rnUfCon (UfLitCon lit)
 788   = returnRn (UfLitCon lit)
 789
 790 rnUfCon (UfLitLitCon lit ty)
 791   = rnIfaceType (text "litlit") ty              `thenRn` \ ty' ->
 792     returnRn (UfLitLitCon lit ty')
 793
 794 rnUfCon (UfPrimOp op)
 795   = lookupOccRn op              `thenRn` \ op' ->
 796     returnRn (UfPrimOp op')
 797
 798 rnUfCon (UfCCallOp str is_dyn casm gc)
 799   = returnRn (UfCCallOp str is_dyn casm gc)
 800 \end{code}
 801
 802 %*********************************************************
 803 %*                                                      *
 804 \subsection{Errors}
 805 %*                                                      *
 806 %*********************************************************
 807
 808 \begin{code}
 809 derivingNonStdClassErr clas
 810   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 811
 812 classTyVarNotInOpTyErr clas_tyvar sig
 813   = hang (hsep [ptext SLIT("Class type variable"),
 814                        quotes (ppr clas_tyvar),
 815                        ptext SLIT("does not appear in method signature")])
 816          4 (ppr sig)
 817
 818 dupClassAssertWarn ctxt (assertion : dups)
 819   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 820                quotes (pprClassAssertion assertion),
 821                ptext SLIT("in the context:")],
 822          nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
 823
 824 badDataCon name
 825    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 826
 827 forAllWarn doc ty tyvar
 828   | not opt_WarnUnusedMatches = returnRn ()
 829   | otherwise
 830   = addWarnRn (
 831       sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 832            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 833       $$
 834       (ptext SLIT("In") <+> doc))
 835
 836 forAllErr doc ty tyvar
 837   = addErrRn (
 838       sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
 839            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 840       $$
 841       (ptext SLIT("In") <+> doc))
 842
 843 ctxtErr explicit_forall doc tyvars constraint ty
 844   = sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
 845                    ptext SLIT("does not mention any of"),
 846          if explicit_forall then
 847            nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars))
 848          else
 849            nest 4 (ptext SLIT("the type variables in the type") <+> quotes (ppr ty))
 850     ]
 851     $$
 852     (ptext SLIT("In") <+> doc)
 853 \end{code}