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 ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) where
   8
   9 #include "HsVersions.h"
  10
  11 import RnExpr
  12 import HsSyn
  13 import HsPragmas
  14 import HsTypes          ( getTyVarName, pprHsPred, cmpHsTypes )
  15 import RdrName          ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
  16 import RdrHsSyn         ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
  17                           extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars
  18                         )
  19 import RnHsSyn
  20 import HsCore
  21
  22 import RnBinds          ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
  23 import RnEnv            ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,
  24                           lookupImplicitOccRn,
  25                           bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
  26                           bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
  27                           bindCoreLocalFVRn, bindCoreLocalsFVRn,
  28                           checkDupOrQualNames, checkDupNames,
  29                           mkImportedGlobalName, mkImportedGlobalFromRdrName,
  30                           newDFunName, getDFunKey, newImplicitBinder,
  31                           FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, mapFvRn
  32                         )
  33 import RnMonad
  34
  35 import FunDeps          ( oclose )
  36
  37 import Name             ( Name, OccName,
  38                           ExportFlag(..), Provenance(..),
  39                           nameOccName, NamedThing(..)
  40                         )
  41 import NameSet
  42 import OccName          ( mkDefaultMethodOcc )
  43 import BasicTypes       ( TopLevelFlag(..) )
  44 import FiniteMap        ( elemFM )
  45 import PrelInfo         ( derivableClassKeys,
  46                           deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME
  47                         )
  48 import Bag              ( bagToList )
  49 import List             ( partition, nub )
  50 import Outputable
  51 import SrcLoc           ( SrcLoc )
  52 import CmdLineOpts      ( opt_GlasgowExts, opt_WarnUnusedMatches )      -- Warn of unused for-all'd tyvars
  53 import Unique           ( Uniquable(..) )
  54 import UniqFM           ( lookupUFM )
  55 import ErrUtils         ( Message )
  56 import CStrings         ( isCLabelString )
  57 import Maybes           ( maybeToBool, catMaybes )
  58 import Util
  59 \end{code}
  60
  61 @rnDecl@ `renames' declarations.
  62 It simultaneously performs dependency analysis and precedence parsing.
  63 It also does the following error checks:
  64 \begin{enumerate}
  65 \item
  66 Checks that tyvars are used properly. This includes checking
  67 for undefined tyvars, and tyvars in contexts that are ambiguous.
  68 (Some of this checking has now been moved to module @TcMonoType@,
  69 since we don't have functional dependency information at this point.)
  70 \item
  71 Checks that all variable occurences are defined.
  72 \item
  73 Checks the @(..)@ etc constraints in the export list.
  74 \end{enumerate}
  75
  76
  77 %*********************************************************
  78 %*                                                      *
  79 \subsection{Value declarations}
  80 %*                                                      *
  81 %*********************************************************
  82
  83 \begin{code}
  84 rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
  85         -- The decls get reversed, but that's ok
  86
  87 rnSourceDecls decls
  88   = go emptyFVs [] decls
  89   where
  90         -- Fixity decls have been dealt with already; ignore them
  91     go fvs ds' []          = returnRn (ds', fvs)
  92     go fvs ds' (FixD _:ds) = go fvs ds' ds
  93     go fvs ds' (d:ds)      = rnDecl d   `thenRn` \(d', fvs') ->
  94                              go (fvs `plusFV` fvs') (d':ds') ds
  95 \end{code}
  96
  97
  98 %*********************************************************
  99 %*                                                      *
 100 \subsection{Value declarations}
 101 %*                                                      *
 102 %*********************************************************
 103
 104 \begin{code}
 105 -- rnDecl does all the work
 106 rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
 107
 108 rnDecl (ValD binds) = rnTopBinds binds  `thenRn` \ (new_binds, fvs) ->
 109                       returnRn (ValD new_binds, fvs)
 110
 111
 112 rnDecl (SigD (IfaceSig name ty id_infos loc))
 113   = pushSrcLocRn loc $
 114     lookupBndrRn name           `thenRn` \ name' ->
 115     rnHsPolyType doc_str ty     `thenRn` \ (ty',fvs1) ->
 116     mapFvRn rnIdInfo id_infos   `thenRn` \ (id_infos', fvs2) ->
 117     returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
 118   where
 119     doc_str = text "the interface signature for" <+> quotes (ppr name)
 120 \end{code}
 121
 122 %*********************************************************
 123 %*                                                      *
 124 \subsection{Type declarations}
 125 %*                                                      *
 126 %*********************************************************
 127
 128 @rnTyDecl@ uses the `global name function' to create a new type
 129 declaration in which local names have been replaced by their original
 130 names, reporting any unknown names.
 131
 132 Renaming type variables is a pain. Because they now contain uniques,
 133 it is necessary to pass in an association list which maps a parsed
 134 tyvar to its @Name@ representation.
 135 In some cases (type signatures of values),
 136 it is even necessary to go over the type first
 137 in order to get the set of tyvars used by it, make an assoc list,
 138 and then go over it again to rename the tyvars!
 139 However, we can also do some scoping checks at the same time.
 140
 141 \begin{code}
 142 rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
 143   = pushSrcLocRn src_loc $
 144     lookupBndrRn tycon                          `thenRn` \ tycon' ->
 145     bindTyVarsFVRn data_doc tyvars              $ \ tyvars' ->
 146     rnContext data_doc context                  `thenRn` \ (context', cxt_fvs) ->
 147     checkDupOrQualNames data_doc con_names      `thenRn_`
 148     mapFvRn rnConDecl condecls                  `thenRn` \ (condecls', con_fvs) ->
 149     rnDerivs derivings                          `thenRn` \ (derivings', deriv_fvs) ->
 150     ASSERT(isNoDataPragmas pragmas)
 151     returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls'
 152                      derivings' noDataPragmas src_loc),
 153               cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
 154   where
 155     data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
 156     con_names = map conDeclName condecls
 157
 158 rnDecl (TyClD (TySynonym name tyvars ty src_loc))
 159   = pushSrcLocRn src_loc $
 160     lookupBndrRn name                           `thenRn` \ name' ->
 161     bindTyVarsFVRn syn_doc tyvars               $ \ tyvars' ->
 162     rnHsPolyType syn_doc (unquantify ty)        `thenRn` \ (ty', ty_fvs) ->
 163     returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
 164   where
 165     syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 166
 167         -- For H98 we do *not* universally quantify on the RHS of a synonym
 168         -- Silently discard context... but the tyvars in the rest won't be in scope
 169     unquantify (HsForAllTy Nothing ctxt ty) | not opt_GlasgowExts = ty
 170     unquantify ty                                                 = ty
 171
 172 rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
 173                tname dname dwname snames 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     mkImportedGlobalFromRdrName tname                   `thenRn` \ tname' ->
 186     mkImportedGlobalFromRdrName dname                   `thenRn` \ dname' ->
 187     mkImportedGlobalFromRdrName dwname                  `thenRn` \ dwname' ->
 188     mapRn mkImportedGlobalFromRdrName snames            `thenRn` \ snames' ->
 189
 190         -- Tyvars scope over bindings and context
 191     bindTyVarsFV2Rn cls_doc tyvars              ( \ clas_tyvar_names tyvars' ->
 192
 193         -- Check the superclasses
 194     rnContext cls_doc context                   `thenRn` \ (context', cxt_fvs) ->
 195
 196         -- Check the functional dependencies
 197     rnFds cls_doc fds                   `thenRn` \ (fds', fds_fvs) ->
 198
 199         -- Check the signatures
 200     let
 201             -- First process the class op sigs, then the fixity sigs.
 202           (op_sigs, non_op_sigs) = partition isClassOpSig sigs
 203     in
 204     checkDupOrQualNames sig_doc sig_rdr_names_w_locs      `thenRn_`
 205     mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs  `thenRn` \ (sigs', sig_fvs) ->
 206     let
 207      binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
 208     in
 209     renameSigs (okClsDclSig binders) non_op_sigs          `thenRn` \ (non_ops', fix_fvs) ->
 210
 211         -- Check the methods
 212     checkDupOrQualNames meth_doc meth_rdr_names_w_locs  `thenRn_`
 213     rnMethodBinds mbinds
 214     `thenRn` \ (mbinds', meth_fvs) ->
 215
 216         -- Typechecker is responsible for checking that we only
 217         -- give default-method bindings for things in this class.
 218         -- The renamer *could* check this for class decls, but can't
 219         -- for instance decls.
 220
 221     ASSERT(isNoClassPragmas pragmas)
 222     returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds'
 223                                NoClassPragmas tname' dname' dwname' snames' src_loc),
 224               sig_fvs   `plusFV`
 225               fix_fvs   `plusFV`
 226               cxt_fvs   `plusFV`
 227               fds_fvs   `plusFV`
 228               meth_fvs
 229              )
 230     )
 231   where
 232     cls_doc  = text "the declaration for class"         <+> ppr cname
 233     sig_doc  = text "the signatures for class"          <+> ppr cname
 234     meth_doc = text "the default-methods for class"     <+> ppr cname
 235
 236     sig_rdr_names_w_locs  = [(op,locn) | ClassOpSig op _ _ _ locn <- sigs]
 237     meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
 238     meth_rdr_names        = map fst meth_rdr_names_w_locs
 239
 240     rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn)
 241       = pushSrcLocRn locn $
 242         lookupBndrRn op                         `thenRn` \ op_name ->
 243
 244                 -- Check the signature
 245         rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
 246         let
 247             check_in_op_ty clas_tyvar =
 248                  checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
 249                          (classTyVarNotInOpTyErr clas_tyvar sig)
 250         in
 251         mapRn_ check_in_op_ty clas_tyvars                `thenRn_`
 252
 253                 -- Make the default-method name
 254         getModeRn                                       `thenRn` \ mode ->
 255         (case mode of
 256             SourceMode -> -- Source class decl
 257                    newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn     `thenRn` \ dm_name ->
 258                    returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs)
 259
 260             InterfaceMode
 261                 ->      -- Imported class that has a default method decl
 262                         -- See comments with tname, snames, above
 263                     lookupImplicitOccRn dm_rdr_name     `thenRn` \ dm_name ->
 264                     returnRn (dm_name, explicit_dm, if explicit_dm then unitFV dm_name else emptyFVs)
 265                         -- An imported class decl for a class decl that had an explicit default
 266                         -- method, mentions, rather than defines,
 267                         -- the default method, so we must arrange to pull it in
 268         )                                               `thenRn` \ (dm_name, final_explicit_dm, dm_fvs) ->
 269
 270         returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs)
 271 \end{code}
 272
 273
 274 %*********************************************************
 275 %*                                                      *
 276 \subsection{Instance declarations}
 277 %*                                                      *
 278 %*********************************************************
 279
 280 \begin{code}
 281 rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
 282   = pushSrcLocRn src_loc $
 283     rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
 284     let
 285         inst_tyvars = case inst_ty' of
 286                         HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
 287                         other                             -> []
 288         -- (Slightly strangely) the forall-d tyvars scope over
 289         -- the method bindings too
 290     in
 291
 292         -- Rename the bindings
 293         -- NB meth_names can be qualified!
 294     checkDupNames meth_doc meth_names           `thenRn_`
 295     extendTyVarEnvFVRn inst_tyvars (
 296         rnMethodBinds mbinds
 297     )                                           `thenRn` \ (mbinds', meth_fvs) ->
 298     let
 299         binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
 300     in
 301         -- Rename the prags and signatures.
 302         -- Note that the type variables are not in scope here,
 303         -- so that      instance Eq a => Eq (T a) where
 304         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 305         -- works OK.
 306     renameSigs (okInstDclSig binders) uprags    `thenRn` \ (new_uprags, prag_fvs) ->
 307
 308     getModeRn           `thenRn` \ mode ->
 309     (case mode of
 310         InterfaceMode -> lookupImplicitOccRn dfun_rdr_name      `thenRn` \ dfun_name ->
 311                          returnRn (dfun_name, unitFV dfun_name)
 312         SourceMode    -> newDFunName (getDFunKey inst_ty') src_loc
 313                          `thenRn` \ dfun_name ->
 314                          returnRn (dfun_name, emptyFVs)
 315     )
 316     `thenRn` \ (dfun_name, dfun_fv) ->
 317
 318     -- The typechecker checks that all the bindings are for the right class.
 319     returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
 320               inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
 321   where
 322     meth_doc = text "the bindings in an instance declaration"
 323     meth_names   = bagToList (collectMonoBinders mbinds)
 324 \end{code}
 325
 326 %*********************************************************
 327 %*                                                      *
 328 \subsection{Default declarations}
 329 %*                                                      *
 330 %*********************************************************
 331
 332 \begin{code}
 333 rnDecl (DefD (DefaultDecl tys src_loc))
 334   = pushSrcLocRn src_loc $
 335     rnHsTypes doc_str tys               `thenRn` \ (tys', fvs) ->
 336     returnRn (DefD (DefaultDecl tys' src_loc), fvs)
 337   where
 338     doc_str = text "a `default' declaration"
 339 \end{code}
 340
 341 %*********************************************************
 342 %*                                                      *
 343 \subsection{Foreign declarations}
 344 %*                                                      *
 345 %*********************************************************
 346
 347 \begin{code}
 348 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
 349   = pushSrcLocRn src_loc $
 350     lookupOccRn name                    `thenRn` \ name' ->
 351     let
 352         ok_ext_nm Dynamic                = True
 353         ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
 354         ok_ext_nm (ExtName nm Nothing)   = isCLabelString nm
 355
 356         fvs1 = case imp_exp of
 357                 FoImport _ | not isDyn  -> emptyFVs
 358                 FoLabel                 -> emptyFVs
 359                 FoExport   | isDyn      -> mkNameSet [makeStablePtr_NAME,
 360                                                       deRefStablePtr_NAME,
 361                                                       bindIO_NAME]
 362                            | otherwise  -> mkNameSet [name']
 363                 _ -> emptyFVs
 364     in
 365     checkRn (ok_ext_nm ext_nm) (badExtName ext_nm)      `thenRn_`
 366     rnHsSigType fo_decl_msg ty                          `thenRn` \ (ty', fvs2) ->
 367     returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
 368               fvs1 `plusFV` fvs2)
 369  where
 370   fo_decl_msg = ptext SLIT("a foreign declaration")
 371   isDyn       = isDynamicExtName ext_nm
 372 \end{code}
 373
 374 %*********************************************************
 375 %*                                                      *
 376 \subsection{Rules}
 377 %*                                                      *
 378 %*********************************************************
 379
 380 \begin{code}
 381 rnDecl (RuleD (IfaceRuleDecl var body src_loc))
 382   = pushSrcLocRn src_loc                        $
 383     lookupOccRn var             `thenRn` \ var' ->
 384     rnRuleBody body             `thenRn` \ (body', fvs) ->
 385     returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
 386
 387 rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
 388   = ASSERT( null tvs )
 389     pushSrcLocRn src_loc                        $
 390
 391     bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
 392     bindLocalsFVRn doc (map get_var vars)       $ \ ids ->
 393     mapFvRn rn_var (vars `zip` ids)             `thenRn` \ (vars', fv_vars) ->
 394
 395     rnExpr lhs                                  `thenRn` \ (lhs', fv_lhs) ->
 396     rnExpr rhs                                  `thenRn` \ (rhs', fv_rhs) ->
 397     checkRn (validRuleLhs ids lhs')
 398             (badRuleLhsErr rule_name lhs')      `thenRn_`
 399     let
 400         bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
 401     in
 402     mapRn (addErrRn . badRuleVar rule_name) bad_vars    `thenRn_`
 403     returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc),
 404               fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
 405   where
 406     doc = text "the transformation rule" <+> ptext rule_name
 407     sig_tvs = extractRuleBndrsTyVars vars
 408
 409     get_var (RuleBndr v)      = v
 410     get_var (RuleBndrSig v _) = v
 411
 412     rn_var (RuleBndr v, id)      = returnRn (RuleBndr id, emptyFVs)
 413     rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t   `thenRn` \ (t', fvs) ->
 414                                    returnRn (RuleBndrSig id t', fvs)
 415 \end{code}
 416
 417
 418 %*********************************************************
 419 %*                                                      *
 420 \subsection{Support code for type/data declarations}
 421 %*                                                      *
 422 %*********************************************************
 423
 424 \begin{code}
 425 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
 426
 427 rnDerivs Nothing -- derivs not specified
 428   = returnRn (Nothing, emptyFVs)
 429
 430 rnDerivs (Just clss)
 431   = mapRn do_one clss   `thenRn` \ clss' ->
 432     returnRn (Just clss', mkNameSet clss')
 433   where
 434     do_one cls = lookupOccRn cls        `thenRn` \ clas_name ->
 435                  checkRn (getUnique clas_name `elem` derivableClassKeys)
 436                          (derivingNonStdClassErr clas_name)     `thenRn_`
 437                  returnRn clas_name
 438 \end{code}
 439
 440 \begin{code}
 441 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 442 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
 443
 444 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
 445 rnConDecl (ConDecl name wkr tvs cxt details locn)
 446   = pushSrcLocRn locn $
 447     checkConName name                   `thenRn_`
 448     lookupBndrRn name                   `thenRn` \ new_name ->
 449
 450     mkImportedGlobalFromRdrName wkr     `thenRn` \ new_wkr ->
 451         -- See comments with ClassDecl
 452
 453     bindTyVarsFVRn doc tvs              $ \ new_tyvars ->
 454     rnContext doc cxt                   `thenRn` \ (new_context, cxt_fvs) ->
 455     rnConDetails doc locn details       `thenRn` \ (new_details, det_fvs) ->
 456     returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn,
 457               cxt_fvs `plusFV` det_fvs)
 458   where
 459     doc = text "the definition of data constructor" <+> quotes (ppr name)
 460
 461 rnConDetails doc locn (VanillaCon tys)
 462   = mapFvRn (rnBangTy doc) tys  `thenRn` \ (new_tys, fvs)  ->
 463     returnRn (VanillaCon new_tys, fvs)
 464
 465 rnConDetails doc locn (InfixCon ty1 ty2)
 466   = rnBangTy doc ty1            `thenRn` \ (new_ty1, fvs1) ->
 467     rnBangTy doc ty2            `thenRn` \ (new_ty2, fvs2) ->
 468     returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
 469
 470 rnConDetails doc locn (NewCon ty mb_field)
 471   = rnHsPolyType doc ty                 `thenRn` \ (new_ty, fvs) ->
 472     rn_field mb_field                   `thenRn` \ new_mb_field  ->
 473     returnRn (NewCon new_ty new_mb_field, fvs)
 474   where
 475     rn_field Nothing  = returnRn Nothing
 476     rn_field (Just f) =
 477        lookupBndrRn f       `thenRn` \ new_f ->
 478        returnRn (Just new_f)
 479
 480 rnConDetails doc locn (RecCon fields)
 481   = checkDupOrQualNames doc field_names `thenRn_`
 482     mapFvRn (rnField doc) fields        `thenRn` \ (new_fields, fvs) ->
 483     returnRn (RecCon new_fields, fvs)
 484   where
 485     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 486
 487 rnField doc (names, ty)
 488   = mapRn lookupBndrRn names    `thenRn` \ new_names ->
 489     rnBangTy doc ty             `thenRn` \ (new_ty, fvs) ->
 490     returnRn ((new_names, new_ty), fvs)
 491
 492 rnBangTy doc (Banged ty)
 493   = rnHsPolyType doc ty         `thenRn` \ (new_ty, fvs) ->
 494     returnRn (Banged new_ty, fvs)
 495
 496 rnBangTy doc (Unbanged ty)
 497   = rnHsPolyType doc ty         `thenRn` \ (new_ty, fvs) ->
 498     returnRn (Unbanged new_ty, fvs)
 499
 500 rnBangTy doc (Unpacked ty)
 501   = rnHsPolyType doc ty         `thenRn` \ (new_ty, fvs) ->
 502     returnRn (Unpacked new_ty, fvs)
 503
 504 -- This data decl will parse OK
 505 --      data T = a Int
 506 -- treating "a" as the constructor.
 507 -- It is really hard to make the parser spot this malformation.
 508 -- So the renamer has to check that the constructor is legal
 509 --
 510 -- We can get an operator as the constructor, even in the prefix form:
 511 --      data T = :% Int Int
 512 -- from interface files, which always print in prefix form
 513
 514 checkConName name
 515   = checkRn (isRdrDataCon name)
 516             (badDataCon name)
 517 \end{code}
 518
 519
 520 %*********************************************************
 521 %*                                                      *
 522 \subsection{Support code to rename types}
 523 %*                                                      *
 524 %*********************************************************
 525
 526 \begin{code}
 527 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 528         -- rnHsSigType is used for source-language type signatures,
 529         -- which use *implicit* universal quantification.
 530 rnHsSigType doc_str ty
 531   = rnHsPolyType (text "the type signature for" <+> doc_str) ty
 532
 533 ---------------------------------------
 534 rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 535 -- rnHsPolyType is prepared to see a for-all; rnHsType is not
 536 -- The former is called for the top level of type sigs and function args.
 537
 538 ---------------------------------------
 539 rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
 540         -- Implicit quantifiction in source code (no kinds on tyvars)
 541         -- Given the signature  C => T  we universally quantify
 542         -- over FV(T) \ {in-scope-tyvars}
 543   = getLocalNameEnv             `thenRn` \ name_env ->
 544     let
 545         mentioned_in_tau = extractHsTyRdrTyVars ty
 546         forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_in_tau
 547     in
 548     checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
 549     rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
 550
 551 rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 552         -- Explicit quantification.
 553         -- Check that the forall'd tyvars are a subset of the
 554         -- free tyvars in the tau-type part
 555         -- That's only a warning... unless the tyvar is constrained by a
 556         -- context in which case it's an error
 557   = let
 558         mentioned_in_tau  = extractHsTyRdrTyVars tau
 559         mentioned_in_ctxt = nub [tv | p <- ctxt,
 560                                       ty <- tys_of_pred p,
 561                                       tv <- extractHsTyRdrTyVars ty]
 562         tys_of_pred (HsPClass clas tys) = tys
 563         tys_of_pred (HsPIParam n ty) = [ty]
 564
 565         dubious_guys          = filter (`notElem` mentioned_in_tau) forall_tyvar_names
 566                 -- dubious = explicitly quantified but not mentioned in tau type
 567
 568         (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
 569                 -- bad  = explicitly quantified and constrained, but not mentioned in tau
 570                 -- warn = explicitly quantified but not mentioned in ctxt or tau
 571
 572         forall_tyvar_names    = map getTyVarName forall_tyvars
 573     in
 574     -- mapRn_ (forAllErr doc tau) bad_guys                                      `thenRn_`
 575     mapRn_ (forAllWarn doc tau) warn_guys                                       `thenRn_`
 576     checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau   `thenRn` \ ctxt' ->
 577     rnForAll doc forall_tyvars ctxt' tau
 578
 579 rnHsPolyType doc other_ty = rnHsType doc other_ty
 580
 581
 582 -- Check that each constraint mentions at least one of the forall'd type variables
 583 -- Since the forall'd type variables are a subset of the free tyvars
 584 -- of the tau-type part, this guarantees that every constraint mentions
 585 -- at least one of the free tyvars in ty
 586 checkConstraints doc forall_tyvars tau_vars ctxt ty
 587    = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->
 588      returnRn (catMaybes maybe_ctxt')
 589             -- Remove problem ones, to avoid duplicate error message.
 590
 591 checkPred doc forall_tyvars ty p@(HsPClass clas tys)
 592   | not_univ  = failWithRn Nothing (univErr  doc p ty)
 593   | otherwise = returnRn (Just p)
 594   where
 595       ct_vars  = extractHsTysRdrTyVars tys
 596       not_univ =  -- At least one of the tyvars in each constraint must
 597                   -- be universally quantified. This restriction isn't in Hugs
 598                   not (any (`elem` forall_tyvars) ct_vars)
 599 checkPred doc forall_tyvars ty p@(HsPIParam _ _)
 600   = returnRn (Just p)
 601
 602 rnForAll doc forall_tyvars ctxt ty
 603   = bindTyVarsFVRn doc forall_tyvars    $ \ new_tyvars ->
 604     rnContext doc ctxt                  `thenRn` \ (new_ctxt, cxt_fvs) ->
 605     rnHsType doc ty                     `thenRn` \ (new_ty, ty_fvs) ->
 606     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
 607               cxt_fvs `plusFV` ty_fvs)
 608
 609 ---------------------------------------
 610 rnHsType doc ty@(HsForAllTy _ _ inner_ty)
 611   = addWarnRn (unexpectedForAllTy ty)   `thenRn_`
 612     rnHsPolyType doc ty
 613
 614 rnHsType doc (MonoTyVar tyvar)
 615   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 616     returnRn (MonoTyVar tyvar', unitFV tyvar')
 617
 618 rnHsType doc (MonoFunTy ty1 ty2)
 619   = rnHsPolyType doc ty1        `thenRn` \ (ty1', fvs1) ->
 620         -- Might find a for-all as the arg of a function type
 621     rnHsPolyType doc ty2        `thenRn` \ (ty2', fvs2) ->
 622         -- Or as the result.  This happens when reading Prelude.hi
 623         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 624     returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
 625
 626 rnHsType doc (MonoListTy ty)
 627   = rnHsType doc ty                             `thenRn` \ (ty', fvs) ->
 628     returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
 629
 630 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 631 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 632 rnHsType doc (MonoTupleTy tys boxed)
 633   = (if boxed
 634       then mapFvRn (rnHsType doc)     tys
 635       else mapFvRn (rnHsPolyType doc) tys)  `thenRn` \ (tys', fvs) ->
 636     returnRn (MonoTupleTy tys' boxed, fvs   `addOneFV` tup_con_name)
 637   where
 638     tup_con_name = tupleTyCon_name boxed (length tys)
 639
 640 rnHsType doc (MonoTyApp ty1 ty2)
 641   = rnHsType doc ty1            `thenRn` \ (ty1', fvs1) ->
 642     rnHsType doc ty2            `thenRn` \ (ty2', fvs2) ->
 643     returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
 644
 645 rnHsType doc (MonoIParamTy n ty)
 646   = getIPName n                 `thenRn` \ name ->
 647     rnHsType doc ty             `thenRn` \ (ty', fvs) ->
 648     returnRn (MonoIParamTy name ty', fvs)
 649
 650 rnHsType doc (MonoDictTy clas tys)
 651   = lookupOccRn clas            `thenRn` \ clas' ->
 652     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 653     returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
 654
 655 rnHsType doc (MonoUsgForAllTy uv_rdr ty)
 656   = bindUVarRn doc uv_rdr $ \ uv_name ->
 657     rnHsType doc ty       `thenRn` \ (ty', fvs) ->
 658     returnRn (MonoUsgForAllTy uv_name ty',
 659               fvs )
 660
 661 rnHsType doc (MonoUsgTy usg ty)
 662   = newUsg usg                          `thenRn` \ (usg', usg_fvs) ->
 663     rnHsPolyType doc ty                 `thenRn` \ (ty', ty_fvs) ->
 664         -- A for-all can occur inside a usage annotation
 665     returnRn (MonoUsgTy usg' ty',
 666               usg_fvs `plusFV` ty_fvs)
 667   where
 668     newUsg usg = case usg of
 669                    MonoUsOnce       -> returnRn (MonoUsOnce, emptyFVs)
 670                    MonoUsMany       -> returnRn (MonoUsMany, emptyFVs)
 671                    MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
 672                                        returnRn (MonoUsVar uv_name, emptyFVs)
 673
 674 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 675 \end{code}
 676
 677
 678 \begin{code}
 679 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 680
 681 rnContext doc ctxt
 682   = mapAndUnzipRn (rnPred doc) ctxt     `thenRn` \ (theta, fvs_s) ->
 683     let
 684         (_, dup_asserts) = removeDups (cmpHsPred compare) theta
 685     in
 686         -- Check for duplicate assertions
 687         -- If this isn't an error, then it ought to be:
 688     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts   `thenRn_`
 689
 690     returnRn (theta, plusFVs fvs_s)
 691
 692 rnPred doc (HsPClass clas tys)
 693   = lookupOccRn clas            `thenRn` \ clas_name ->
 694     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 695     returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
 696 rnPred doc (HsPIParam n ty)
 697   = getIPName n                 `thenRn` \ name ->
 698     rnHsType doc ty             `thenRn` \ (ty', fvs) ->
 699     returnRn (HsPIParam name ty', fvs)
 700 \end{code}
 701
 702 \begin{code}
 703 rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars)
 704
 705 rnFds doc fds
 706   = mapAndUnzipRn rn_fds fds            `thenRn` \ (theta, fvs_s) ->
 707     returnRn (theta, plusFVs fvs_s)
 708   where
 709     rn_fds (tys1, tys2)
 710       = rnHsTyVars doc tys1             `thenRn` \ (tys1', fvs1) ->
 711         rnHsTyVars doc tys2             `thenRn` \ (tys2', fvs2) ->
 712         returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
 713
 714 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
 715 rnHsTyvar doc tyvar
 716   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 717     returnRn (tyvar', unitFV tyvar')
 718 \end{code}
 719
 720 %*********************************************************
 721 %*                                                       *
 722 \subsection{IdInfo}
 723 %*                                                       *
 724 %*********************************************************
 725
 726 \begin{code}
 727 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
 728
 729 rnIdInfo (HsWorker worker)
 730   = lookupOccRn worker                  `thenRn` \ worker' ->
 731     returnRn (HsWorker worker', unitFV worker')
 732
 733 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
 734                                   returnRn (HsUnfold inline expr', fvs)
 735 rnIdInfo (HsArity arity)        = returnRn (HsArity arity, emptyFVs)
 736 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update, emptyFVs)
 737 rnIdInfo HsNoCafRefs            = returnRn (HsNoCafRefs, emptyFVs)
 738 rnIdInfo HsCprInfo              = returnRn (HsCprInfo, emptyFVs)
 739 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
 740                                     `thenRn` \ (rule_body', fvs) ->
 741                                     returnRn (HsSpecialise rule_body', fvs)
 742
 743 rnRuleBody (UfRuleBody str vars args rhs)
 744   = rnCoreBndrs vars            $ \ vars' ->
 745     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs1) ->
 746     rnCoreExpr rhs              `thenRn` \ (rhs',  fvs2) ->
 747     returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
 748 \end{code}
 749
 750 @UfCore@ expressions.
 751
 752 \begin{code}
 753 rnCoreExpr (UfType ty)
 754   = rnHsPolyType (text "unfolding type") ty     `thenRn` \ (ty', fvs) ->
 755     returnRn (UfType ty', fvs)
 756
 757 rnCoreExpr (UfVar v)
 758   = lookupOccRn v       `thenRn` \ v' ->
 759     returnRn (UfVar v', unitFV v')
 760
 761 rnCoreExpr (UfLit l)
 762   = returnRn (UfLit l, emptyFVs)
 763
 764 rnCoreExpr (UfLitLit l ty)
 765   = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
 766     returnRn (UfLitLit l ty', fvs)
 767
 768 rnCoreExpr (UfCCall cc ty)
 769   = rnHsPolyType (text "ccall") ty      `thenRn` \ (ty', fvs) ->
 770     returnRn (UfCCall cc ty', fvs)
 771
 772 rnCoreExpr (UfTuple con args)
 773   = lookupOccRn con             `thenRn` \ con' ->
 774     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs) ->
 775     returnRn (UfTuple con' args', fvs `addOneFV` con')
 776
 777 rnCoreExpr (UfApp fun arg)
 778   = rnCoreExpr fun              `thenRn` \ (fun', fv1) ->
 779     rnCoreExpr arg              `thenRn` \ (arg', fv2) ->
 780     returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
 781
 782 rnCoreExpr (UfCase scrut bndr alts)
 783   = rnCoreExpr scrut                    `thenRn` \ (scrut', fvs1) ->
 784     bindCoreLocalFVRn bndr              ( \ bndr' ->
 785         mapFvRn rnCoreAlt alts          `thenRn` \ (alts', fvs2) ->
 786         returnRn (UfCase scrut' bndr' alts', fvs2)
 787     )                                           `thenRn` \ (case', fvs3) ->
 788     returnRn (case', fvs1 `plusFV` fvs3)
 789
 790 rnCoreExpr (UfNote note expr)
 791   = rnNote note                 `thenRn` \ (note', fvs1) ->
 792     rnCoreExpr expr             `thenRn` \ (expr', fvs2) ->
 793     returnRn  (UfNote note' expr', fvs1 `plusFV` fvs2)
 794
 795 rnCoreExpr (UfLam bndr body)
 796   = rnCoreBndr bndr             $ \ bndr' ->
 797     rnCoreExpr body             `thenRn` \ (body', fvs) ->
 798     returnRn (UfLam bndr' body', fvs)
 799
 800 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 801   = rnCoreExpr rhs              `thenRn` \ (rhs', fvs1) ->
 802     rnCoreBndr bndr             ( \ bndr' ->
 803         rnCoreExpr body         `thenRn` \ (body', fvs2) ->
 804         returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
 805     )                           `thenRn` \ (result, fvs3) ->
 806     returnRn (result, fvs1 `plusFV` fvs3)
 807
 808 rnCoreExpr (UfLet (UfRec pairs) body)
 809   = rnCoreBndrs bndrs           $ \ bndrs' ->
 810     mapFvRn rnCoreExpr rhss     `thenRn` \ (rhss', fvs1) ->
 811     rnCoreExpr body             `thenRn` \ (body', fvs2) ->
 812     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
 813   where
 814     (bndrs, rhss) = unzip pairs
 815 \end{code}
 816
 817 \begin{code}
 818 rnCoreBndr (UfValBinder name ty) thing_inside
 819   = rnHsPolyType doc ty         `thenRn` \ (ty', fvs1) ->
 820     bindCoreLocalFVRn name      ( \ name' ->
 821             thing_inside (UfValBinder name' ty')
 822     )                           `thenRn` \ (result, fvs2) ->
 823     returnRn (result, fvs1 `plusFV` fvs2)
 824   where
 825     doc = text "unfolding id"
 826
 827 rnCoreBndr (UfTyBinder name kind) thing_inside
 828   = bindCoreLocalFVRn name              $ \ name' ->
 829     thing_inside (UfTyBinder name' kind)
 830
 831 rnCoreBndrs []     thing_inside = thing_inside []
 832 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 833                                   rnCoreBndrs bs        $ \ names' ->
 834                                   thing_inside (name':names')
 835 \end{code}
 836
 837 \begin{code}
 838 rnCoreAlt (con, bndrs, rhs)
 839   = rnUfCon con                         `thenRn` \ (con', fvs1) ->
 840     bindCoreLocalsFVRn bndrs            ( \ bndrs' ->
 841         rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
 842         returnRn ((con', bndrs', rhs'), fvs2)
 843     )                                   `thenRn` \ (result, fvs3) ->
 844     returnRn (result, fvs1 `plusFV` fvs3)
 845
 846 rnNote (UfCoerce ty)
 847   = rnHsPolyType (text "unfolding coerce") ty   `thenRn` \ (ty', fvs) ->
 848     returnRn (UfCoerce ty', fvs)
 849
 850 rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
 851 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
 852 rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
 853
 854
 855 rnUfCon UfDefault
 856   = returnRn (UfDefault, emptyFVs)
 857
 858 rnUfCon (UfDataAlt con)
 859   = lookupOccRn con             `thenRn` \ con' ->
 860     returnRn (UfDataAlt con', unitFV con')
 861
 862 rnUfCon (UfLitAlt lit)
 863   = returnRn (UfLitAlt lit, emptyFVs)
 864
 865 rnUfCon (UfLitLitAlt lit ty)
 866   = rnHsPolyType (text "litlit") ty             `thenRn` \ (ty', fvs) ->
 867     returnRn (UfLitLitAlt lit ty', fvs)
 868 \end{code}
 869
 870 %*********************************************************
 871 %*                                                       *
 872 \subsection{Rule shapes}
 873 %*                                                       *
 874 %*********************************************************
 875
 876 Check the shape of a transformation rule LHS.  Currently
 877 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 878 not one of the @forall@'d variables.
 879
 880 \begin{code}
 881 validRuleLhs foralls lhs
 882   = check lhs
 883   where
 884     check (HsApp e1 e2)                   = check e1
 885     check (HsVar v) | v `notElem` foralls = True
 886     check other                           = False
 887 \end{code}
 888
 889
 890 %*********************************************************
 891 %*                                                       *
 892 \subsection{Errors}
 893 %*                                                       *
 894 %*********************************************************
 895
 896 \begin{code}
 897 derivingNonStdClassErr clas
 898   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 899
 900 classTyVarNotInOpTyErr clas_tyvar sig
 901   = hang (hsep [ptext SLIT("Class type variable"),
 902                        quotes (ppr clas_tyvar),
 903                        ptext SLIT("does not appear in method signature")])
 904          4 (ppr sig)
 905
 906 dupClassAssertWarn ctxt (assertion : dups)
 907   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 908                quotes (pprHsPred assertion),
 909                ptext SLIT("in the context:")],
 910          nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
 911
 912 badDataCon name
 913    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 914
 915 forAllWarn doc ty tyvar
 916   | not opt_WarnUnusedMatches = returnRn ()
 917   | otherwise
 918   = getModeRn           `thenRn` \ mode ->
 919     case mode of {
 920 #ifndef DEBUG
 921         InterfaceMode -> returnRn () ;  -- Don't warn of unused tyvars in interface files
 922                                         -- unless DEBUG is on, in which case it is slightly
 923                                         -- informative.  They can arise from mkRhsTyLam,
 924 #endif                                  -- leading to (say)     f :: forall a b. [b] -> [b]
 925         other ->
 926
 927     addWarnRn (
 928       sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 929            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 930       $$
 931       (ptext SLIT("In") <+> doc))
 932     }
 933
 934 forAllErr doc ty tyvar
 935   = addErrRn (
 936       sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
 937            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 938       $$
 939       (ptext SLIT("In") <+> doc))
 940
 941 univErr doc constraint ty
 942   = sep [ptext SLIT("All of the type variable(s) in the constraint")
 943           <+> quotes (pprHsPred constraint)
 944           <+> ptext SLIT("are already in scope"),
 945          nest 4 (ptext SLIT("At least one must be universally quantified here"))
 946     ]
 947     $$
 948     (ptext SLIT("In") <+> doc)
 949
 950 ambigErr doc constraint ty
 951   = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint),
 952          nest 4 (ptext SLIT("in the type:") <+> ppr ty),
 953          nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
 954     $$
 955     (ptext SLIT("In") <+> doc)
 956
 957 unexpectedForAllTy ty
 958   = ptext SLIT("Unexpected forall type:") <+> ppr ty
 959
 960 badRuleLhsErr name lhs
 961   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 962          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 963     $$
 964     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 965
 966 badRuleVar name var
 967   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 968          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 969                 ptext SLIT("does not appear on left hand side")]
 970
 971 badExtName :: ExtName -> Message
 972 badExtName ext_nm
 973   = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
 974 \end{code}