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