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          ( getTyVarName, pprClassAssertion, cmpHsTypes )
  15 import RdrName          ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
  16 import RdrHsSyn         ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
  17                           extractHsTyRdrNames, extractRuleBndrsTyVars
  18                         )
  19 import RnHsSyn
  20 import HsCore
  21
  22 import RnBinds          ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
  23 import RnEnv            ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
  24                           lookupImplicitOccRn,
  25                           bindLocalsRn, bindLocalRn, bindLocalsFVRn,
  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 Name             ( Name, OccName,
  36                           ExportFlag(..), Provenance(..),
  37                           nameOccName, NamedThing(..)
  38                         )
  39 import NameSet
  40 import OccName          ( mkDefaultMethodOcc )
  41 import BasicTypes       ( TopLevelFlag(..) )
  42 import FiniteMap        ( elemFM )
  43 import PrelInfo         ( derivingOccurrences, numClass_RDR,
  44                           deRefStablePtr_NAME, makeStablePtr_NAME,
  45                           bindIO_NAME
  46                         )
  47 import Bag              ( bagToList )
  48 import List             ( partition )
  49 import Outputable
  50 import SrcLoc           ( SrcLoc )
  51 import CmdLineOpts      ( opt_WarnUnusedMatches )       -- Warn of unused for-all'd tyvars
  52 import UniqFM           ( lookupUFM )
  53 import Maybes           ( maybeToBool, catMaybes )
  54 import Util
  55 \end{code}
  56
  57 rnDecl `renames' declarations.
  58 It simultaneously performs dependency analysis and precedence parsing.
  59 It also does the following error checks:
  60 \begin{enumerate}
  61 \item
  62 Checks that tyvars are used properly. This includes checking
  63 for undefined tyvars, and tyvars in contexts that are ambiguous.
  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 decls 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' (d:ds)      = rnDecl d   `thenRn` \(d', fvs') ->
  88                              go (fvs `plusFV` fvs') (d':ds') ds
  89 \end{code}
  90
  91
  92 %*********************************************************
  93 %*                                                      *
  94 \subsection{Value declarations}
  95 %*                                                      *
  96 %*********************************************************
  97
  98 \begin{code}
  99 -- rnDecl does all the work
 100 rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
 101
 102 rnDecl (ValD binds) = rnTopBinds binds  `thenRn` \ (new_binds, fvs) ->
 103                       returnRn (ValD new_binds, fvs)
 104
 105
 106 rnDecl (SigD (IfaceSig name ty id_infos loc))
 107   = pushSrcLocRn loc $
 108     lookupBndrRn name           `thenRn` \ name' ->
 109     rnHsType doc_str ty         `thenRn` \ (ty',fvs1) ->
 110     mapFvRn rnIdInfo id_infos   `thenRn` \ (id_infos', fvs2) ->
 111     returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
 112   where
 113     doc_str = text "the interface signature for" <+> quotes (ppr name)
 114 \end{code}
 115
 116 %*********************************************************
 117 %*                                                      *
 118 \subsection{Type declarations}
 119 %*                                                      *
 120 %*********************************************************
 121
 122 @rnTyDecl@ uses the `global name function' to create a new type
 123 declaration in which local names have been replaced by their original
 124 names, reporting any unknown names.
 125
 126 Renaming type variables is a pain. Because they now contain uniques,
 127 it is necessary to pass in an association list which maps a parsed
 128 tyvar to its Name representation. In some cases (type signatures of
 129 values), it is even necessary to go over the type first in order to
 130 get the set of tyvars used by it, make an assoc list, and then go over
 131 it again to rename the tyvars! However, we can also do some scoping
 132 checks at the same time.
 133
 134 \begin{code}
 135 rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
 136   = pushSrcLocRn src_loc $
 137     lookupBndrRn tycon                                  `thenRn` \ tycon' ->
 138     bindTyVarsFVRn data_doc tyvars                      $ \ tyvars' ->
 139     rnContext data_doc context                          `thenRn` \ (context', cxt_fvs) ->
 140     checkDupOrQualNames data_doc con_names              `thenRn_`
 141     mapFvRn rnConDecl condecls                          `thenRn` \ (condecls', con_fvs) ->
 142     rnDerivs derivings                                  `thenRn` \ (derivings', deriv_fvs) ->
 143     ASSERT(isNoDataPragmas pragmas)
 144     returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc),
 145               cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
 146   where
 147     data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
 148     con_names = map conDeclName condecls
 149
 150 rnDecl (TyClD (TySynonym name tyvars ty src_loc))
 151   = pushSrcLocRn src_loc $
 152     lookupBndrRn name                           `thenRn` \ name' ->
 153     bindTyVarsFVRn syn_doc tyvars               $ \ tyvars' ->
 154     rnHsType syn_doc ty                         `thenRn` \ (ty', ty_fvs) ->
 155     returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
 156   where
 157     syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 158
 159 rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname snames src_loc))
 160   = pushSrcLocRn src_loc $
 161
 162     lookupBndrRn cname                                  `thenRn` \ cname' ->
 163
 164         -- Deal with the implicit tycon and datacon name
 165         -- They aren't in scope (because they aren't visible to the user)
 166         -- and what we want to do is simply look them up in the cache;
 167         -- we jolly well ought to get a 'hit' there!
 168         -- So the 'Imported' part of this call is not relevant.
 169         -- Unclean; but since these two are the only place this happens
 170         -- I can't work up the energy to do it more beautifully
 171     mkImportedGlobalFromRdrName tname                   `thenRn` \ tname' ->
 172     mkImportedGlobalFromRdrName dname                   `thenRn` \ dname' ->
 173     mapRn mkImportedGlobalFromRdrName snames            `thenRn` \ snames' ->
 174
 175         -- Tyvars scope over bindings and context
 176     bindTyVarsFV2Rn cls_doc tyvars                      ( \ clas_tyvar_names tyvars' ->
 177
 178         -- Check the superclasses
 179     rnContext cls_doc context                           `thenRn` \ (context', cxt_fvs) ->
 180
 181         -- Check the signatures
 182     let
 183             -- First process the class op sigs, then the fixity sigs.
 184           (op_sigs, non_op_sigs) = partition isClassOpSig sigs
 185           (fix_sigs, non_sigs)   = partition isFixitySig  non_op_sigs
 186     in
 187     checkDupOrQualNames sig_doc sig_rdr_names_w_locs    `thenRn_`
 188     mapFvRn (rn_op cname' clas_tyvar_names) op_sigs     `thenRn` \ (sigs', sig_fvs) ->
 189     mapRn_  (unknownSigErr) non_sigs                    `thenRn_`
 190     let
 191      binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
 192     in
 193     renameSigs False binders lookupOccRn fix_sigs         `thenRn` \ (fixs', fix_fvs) ->
 194
 195         -- Check the methods
 196     checkDupOrQualNames meth_doc meth_rdr_names_w_locs  `thenRn_`
 197     rnMethodBinds mbinds                                `thenRn` \ (mbinds', meth_fvs) ->
 198
 199         -- Typechecker is responsible for checking that we only
 200         -- give default-method bindings for things in this class.
 201         -- The renamer *could* check this for class decls, but can't
 202         -- for instance decls.
 203
 204     ASSERT(isNoClassPragmas pragmas)
 205     returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs')
 206                                mbinds' NoClassPragmas tname' dname' snames' src_loc),
 207               sig_fvs   `plusFV`
 208               fix_fvs   `plusFV`
 209               cxt_fvs   `plusFV`
 210               meth_fvs
 211              )
 212     )
 213   where
 214     cls_doc  = text "the declaration for class"         <+> ppr cname
 215     sig_doc  = text "the signatures for class"          <+> ppr cname
 216     meth_doc = text "the default-methods for class"     <+> ppr cname
 217
 218     sig_rdr_names_w_locs  = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
 219     meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
 220     meth_rdr_names        = map fst meth_rdr_names_w_locs
 221
 222     rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn)
 223       = pushSrcLocRn locn $
 224         lookupBndrRn op                         `thenRn` \ op_name ->
 225
 226                 -- Check the signature
 227         rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
 228         let
 229             check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
 230                                                 (classTyVarNotInOpTyErr clas_tyvar sig)
 231         in
 232         mapRn_ check_in_op_ty clas_tyvars                `thenRn_`
 233
 234                 -- Make the default-method name
 235         getModeRn                                       `thenRn` \ mode ->
 236         (case (mode, maybe_dm) of
 237             (SourceMode, _)
 238                 | op `elem` meth_rdr_names
 239                 ->      -- Source class decl with an explicit method decl
 240                         newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn     `thenRn` \ dm_name ->
 241                         returnRn (Just dm_name, emptyFVs)
 242
 243                 | otherwise
 244                 ->      -- Source class dec, no explicit method decl
 245                         returnRn (Nothing, emptyFVs)
 246
 247             (InterfaceMode, Just dm_rdr_name)
 248                 ->      -- Imported class that has a default method decl
 249                         -- See comments with tname, snames, above
 250                     lookupImplicitOccRn dm_rdr_name             `thenRn` \ dm_name ->
 251                     returnRn (Just dm_name, unitFV dm_name)
 252                             -- An imported class decl mentions, rather than defines,
 253                             -- the default method, so we must arrange to pull it in
 254
 255             (InterfaceMode, Nothing)
 256                         -- Imported class with no default metho
 257                 ->      returnRn (Nothing, emptyFVs)
 258         )                                               `thenRn` \ (maybe_dm_name, dm_fvs) ->
 259
 260         returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs `plusFV` dm_fvs)
 261 \end{code}
 262
 263
 264 %*********************************************************
 265 %*                                                      *
 266 \subsection{Instance declarations}
 267 %*                                                      *
 268 %*********************************************************
 269
 270 \begin{code}
 271 rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
 272   = pushSrcLocRn src_loc $
 273     rnHsSigType (text "an instance decl") inst_ty       `thenRn` \ (inst_ty', inst_fvs) ->
 274     let
 275         inst_tyvars = case inst_ty' of
 276                         HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
 277                         other                             -> []
 278         -- (Slightly strangely) the forall-d tyvars scope over
 279         -- the method bindings too
 280     in
 281
 282         -- Rename the bindings
 283         -- NB meth_names can be qualified!
 284     checkDupNames meth_doc meth_names           `thenRn_`
 285     extendTyVarEnvFVRn inst_tyvars (
 286         rnMethodBinds mbinds
 287     )                                           `thenRn` \ (mbinds', meth_fvs) ->
 288     let
 289         binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
 290
 291         -- Delete sigs (&report) sigs that aren't allowed inside an
 292         -- instance decl:
 293         --
 294         --  + type signatures
 295         --  + fixity decls
 296         --
 297         (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
 298
 299         okInInstDecl (FixSig _)  = False
 300         okInInstDecl (Sig _ _ _) = False
 301         okInInstDecl _           = True
 302
 303     in
 304       -- You can't have fixity decls & type signatures
 305       -- within an instance declaration.
 306     mapRn_ unknownSigErr not_ok_idecl_sigs       `thenRn_`
 307
 308         -- Rename the prags and signatures.
 309         -- Note that the type variables are not in scope here,
 310         -- so that      instance Eq a => Eq (T a) where
 311         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 312         -- works OK.
 313     renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
 314
 315     getModeRn           `thenRn` \ mode ->
 316     (case mode of
 317         InterfaceMode -> lookupImplicitOccRn dfun_rdr_name              `thenRn` \ dfun_name ->
 318                          returnRn (dfun_name, unitFV dfun_name)
 319         SourceMode    -> newDFunName (getDFunKey inst_ty') src_loc      `thenRn` \ dfun_name ->
 320                          returnRn (dfun_name, emptyFVs)
 321     )                                                           `thenRn` \ (dfun_name, dfun_fv) ->
 322
 323         -- The typechecker checks that all the bindings are for the right class.
 324     returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
 325               inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
 326   where
 327     meth_doc = text "the bindings in an instance declaration"
 328     meth_names   = bagToList (collectMonoBinders mbinds)
 329 \end{code}
 330
 331 %*********************************************************
 332 %*                                                      *
 333 \subsection{Default declarations}
 334 %*                                                      *
 335 %*********************************************************
 336
 337 \begin{code}
 338 rnDecl (DefD (DefaultDecl tys src_loc))
 339   = pushSrcLocRn src_loc $
 340     rnHsTypes doc_str tys               `thenRn` \ (tys', fvs) ->
 341     lookupImplicitOccRn numClass_RDR    `thenRn` \ num ->
 342     returnRn (DefD (DefaultDecl tys' src_loc), fvs `addOneFV` num)
 343   where
 344     doc_str = text "a `default' declaration"
 345 \end{code}
 346
 347 %*********************************************************
 348 %*                                                      *
 349 \subsection{Foreign declarations}
 350 %*                                                      *
 351 %*********************************************************
 352
 353 \begin{code}
 354 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
 355   = pushSrcLocRn src_loc $
 356     lookupBndrRn name                   `thenRn` \ name' ->
 357     let
 358         fvs1 = case imp_exp of
 359                 FoImport _ | not isDyn  -> emptyFVs
 360                 FoLabel                 -> emptyFVs
 361                 FoExport   | isDyn      -> mkNameSet [makeStablePtr_NAME,
 362                                                       deRefStablePtr_NAME,
 363                                                       bindIO_NAME]
 364                 _ -> emptyFVs
 365     in
 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       = isDynamic 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) = rnHsType 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 ds)
 431   = mapFvRn rn_deriv ds         `thenRn` \ (derivs, fvs) ->
 432     returnRn (Just derivs, fvs)
 433   where
 434     rn_deriv clas
 435       = lookupOccRn clas            `thenRn` \ clas_name ->
 436
 437                 -- Now add extra "occurrences" for things that
 438                 -- the deriving mechanism will later need in order to
 439                 -- generate code for this class.
 440         case lookupUFM derivingOccurrences clas_name of
 441                 Nothing -> addErrRn (derivingNonStdClassErr clas_name)  `thenRn_`
 442                            returnRn (clas_name, unitFV clas_name)
 443
 444                 Just occs -> mapRn lookupImplicitOccRn occs     `thenRn` \ names ->
 445                              returnRn (clas_name, mkNameSet (clas_name : names))
 446 \end{code}
 447
 448 \begin{code}
 449 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 450 conDeclName (ConDecl n _ _ _ l) = (n,l)
 451
 452 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
 453 rnConDecl (ConDecl name tvs cxt details locn)
 454   = pushSrcLocRn locn $
 455     checkConName name                   `thenRn_`
 456     lookupBndrRn name                   `thenRn` \ new_name ->
 457     bindTyVarsFVRn doc tvs              $ \ new_tyvars ->
 458     rnContext doc cxt                   `thenRn` \ (new_context, cxt_fvs) ->
 459     rnConDetails doc locn details       `thenRn` \ (new_details, det_fvs) ->
 460     returnRn (ConDecl new_name new_tyvars new_context new_details locn,
 461               cxt_fvs `plusFV` det_fvs)
 462   where
 463     doc = text "the definition of data constructor" <+> quotes (ppr name)
 464
 465 rnConDetails doc locn (VanillaCon tys)
 466   = mapFvRn (rnBangTy doc) tys  `thenRn` \ (new_tys, fvs)  ->
 467     returnRn (VanillaCon new_tys, fvs)
 468
 469 rnConDetails doc locn (InfixCon ty1 ty2)
 470   = rnBangTy doc ty1            `thenRn` \ (new_ty1, fvs1) ->
 471     rnBangTy doc ty2            `thenRn` \ (new_ty2, fvs2) ->
 472     returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
 473
 474 rnConDetails doc locn (NewCon ty mb_field)
 475   = rnHsType doc ty                     `thenRn` \ (new_ty, fvs) ->
 476     rn_field mb_field                   `thenRn` \ new_mb_field  ->
 477     returnRn (NewCon new_ty new_mb_field, fvs)
 478   where
 479     rn_field Nothing  = returnRn Nothing
 480     rn_field (Just f) =
 481        lookupBndrRn f       `thenRn` \ new_f ->
 482        returnRn (Just new_f)
 483
 484 rnConDetails doc locn (RecCon fields)
 485   = checkDupOrQualNames doc field_names `thenRn_`
 486     mapFvRn (rnField doc) fields        `thenRn` \ (new_fields, fvs) ->
 487     returnRn (RecCon new_fields, fvs)
 488   where
 489     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 490
 491 rnField doc (names, ty)
 492   = mapRn lookupBndrRn names    `thenRn` \ new_names ->
 493     rnBangTy doc ty             `thenRn` \ (new_ty, fvs) ->
 494     returnRn ((new_names, new_ty), fvs)
 495
 496 rnBangTy doc (Banged ty)
 497   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 498     returnRn (Banged new_ty, fvs)
 499
 500 rnBangTy doc (Unbanged ty)
 501   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 502     returnRn (Unbanged new_ty, fvs)
 503
 504 rnBangTy doc (Unpacked ty)
 505   = rnHsType doc ty             `thenRn` \ (new_ty, fvs) ->
 506     returnRn (Unpacked new_ty, fvs)
 507
 508 -- This data decl will parse OK
 509 --      data T = a Int
 510 -- treating "a" as the constructor.
 511 -- It is really hard to make the parser spot this malformation.
 512 -- So the renamer has to check that the constructor is legal
 513 --
 514 -- We can get an operator as the constructor, even in the prefix form:
 515 --      data T = :% Int Int
 516 -- from interface files, which always print in prefix form
 517
 518 checkConName name
 519   = checkRn (isRdrDataCon name)
 520             (badDataCon name)
 521 \end{code}
 522
 523
 524 %*********************************************************
 525 %*                                                      *
 526 \subsection{Support code to rename types}
 527 %*                                                      *
 528 %*********************************************************
 529
 530 \begin{code}
 531 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 532         -- rnHsSigType is used for source-language type signatures,
 533         -- which use *implicit* universal quantification.
 534 rnHsSigType doc_str ty
 535   = rnHsType (text "the type signature for" <+> doc_str) ty
 536
 537 rnForAll doc forall_tyvars ctxt ty
 538   = bindTyVarsFVRn doc forall_tyvars                    $ \ new_tyvars ->
 539     rnContext doc ctxt                                  `thenRn` \ (new_ctxt, cxt_fvs) ->
 540     rnHsType doc ty                                     `thenRn` \ (new_ty, ty_fvs) ->
 541     returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
 542               cxt_fvs `plusFV` ty_fvs)
 543
 544 -- Check that each constraint mentions at least one of the forall'd type variables
 545 -- Since the forall'd type variables are a subset of the free tyvars
 546 -- of the tau-type part, this guarantees that every constraint mentions
 547 -- at least one of the free tyvars in ty
 548 checkConstraints explicit_forall doc forall_tyvars ctxt ty
 549    = mapRn check ctxt                   `thenRn` \ maybe_ctxt' ->
 550      returnRn (catMaybes maybe_ctxt')
 551             -- Remove problem ones, to avoid duplicate error message.
 552    where
 553      check ct@(_,tys)
 554         | forall_mentioned = returnRn (Just ct)
 555         | otherwise        = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty) `thenRn_`
 556                              returnRn Nothing
 557         where
 558           forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyRdrNames)
 559                              False
 560                              tys
 561
 562
 563 rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 564
 565 rnHsType doc (HsForAllTy Nothing ctxt ty)
 566         -- From source code (no kinds on tyvars)
 567         -- Given the signature  C => T  we universally quantify
 568         -- over FV(T) \ {in-scope-tyvars}
 569   = getLocalNameEnv             `thenRn` \ name_env ->
 570     let
 571         mentioned_tyvars = filter isRdrTyVar (extractHsTyRdrNames ty)
 572         forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_tyvars
 573     in
 574     checkConstraints False doc forall_tyvars ctxt ty    `thenRn` \ ctxt' ->
 575     rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
 576
 577 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt ty)
 578         -- Explicit quantification.
 579         -- Check that the forall'd tyvars are a subset of the
 580         -- free tyvars in the tau-type part
 581         -- That's only a warning... unless the tyvar is constrained by a
 582         -- context in which case it's an error
 583   = let
 584         mentioned_tyvars      = filter isRdrTyVar (extractHsTyRdrNames ty)
 585         constrained_tyvars    = [tv | (_,tys) <- ctxt,
 586                                       ty <- tys,
 587                                       tv <- mentioned_tyvars]
 588         dubious_guys          = filter (`notElem` mentioned_tyvars) forall_tyvar_names
 589         (bad_guys, warn_guys) = partition (`elem` constrained_tyvars) dubious_guys
 590         forall_tyvar_names    = map getTyVarName forall_tyvars
 591     in
 592     mapRn_ (forAllErr doc ty) bad_guys                          `thenRn_`
 593     mapRn_ (forAllWarn doc ty) warn_guys                        `thenRn_`
 594     checkConstraints True doc forall_tyvar_names ctxt ty        `thenRn` \ ctxt' ->
 595     rnForAll doc forall_tyvars ctxt' ty
 596
 597 rnHsType doc (MonoTyVar tyvar)
 598   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 599     returnRn (MonoTyVar tyvar', unitFV tyvar')
 600
 601 rnHsType doc (MonoFunTy ty1 ty2)
 602   = rnHsType doc ty1    `thenRn` \ (ty1', fvs1) ->
 603     rnHsType doc ty2    `thenRn` \ (ty2', fvs2) ->
 604     returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
 605
 606 rnHsType doc (MonoListTy ty)
 607   = rnHsType doc ty                             `thenRn` \ (ty', fvs) ->
 608     returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
 609
 610 rnHsType doc (MonoTupleTy tys boxed)
 611   = rnHsTypes doc tys                   `thenRn` \ (tys', fvs) ->
 612     returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
 613   where
 614     tup_con_name = tupleTyCon_name boxed (length tys)
 615
 616 rnHsType doc (MonoTyApp ty1 ty2)
 617   = rnHsType doc ty1            `thenRn` \ (ty1', fvs1) ->
 618     rnHsType doc ty2            `thenRn` \ (ty2', fvs2) ->
 619     returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
 620
 621 rnHsType doc (MonoDictTy clas tys)
 622   = lookupOccRn clas            `thenRn` \ clas' ->
 623     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 624     returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
 625
 626 rnHsType doc (MonoUsgTy usg ty)
 627   = rnHsType doc ty             `thenRn` \ (ty', fvs) ->
 628     returnRn (MonoUsgTy usg ty', fvs)
 629
 630 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 631 \end{code}
 632
 633
 634 \begin{code}
 635 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 636
 637 rnContext doc ctxt
 638   = mapAndUnzipRn rn_ctxt ctxt          `thenRn` \ (theta, fvs_s) ->
 639     let
 640         (_, dup_asserts) = removeDups cmp_assert theta
 641     in
 642         -- Check for duplicate assertions
 643         -- If this isn't an error, then it ought to be:
 644     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts   `thenRn_`
 645
 646     returnRn (theta, plusFVs fvs_s)
 647   where
 648     rn_ctxt (clas, tys)
 649       = lookupOccRn clas                `thenRn` \ clas_name ->
 650         rnHsTypes doc tys               `thenRn` \ (tys', fvs) ->
 651         returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
 652
 653     cmp_assert (c1,tys1) (c2,tys2)
 654       = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
 655 \end{code}
 656
 657
 658 %*********************************************************
 659 %*                                                      *
 660 \subsection{IdInfo}
 661 %*                                                      *
 662 %*********************************************************
 663
 664 \begin{code}
 665 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
 666
 667 rnIdInfo (HsWorker worker)
 668   = lookupOccRn worker                  `thenRn` \ worker' ->
 669     returnRn (HsWorker worker', unitFV worker')
 670
 671 rnIdInfo (HsUnfold inline (Just expr))  = rnCoreExpr expr       `thenRn` \ (expr', fvs) ->
 672                                           returnRn (HsUnfold inline (Just expr'), fvs)
 673 rnIdInfo (HsUnfold inline Nothing)      = returnRn (HsUnfold inline Nothing, emptyFVs)
 674 rnIdInfo (HsArity arity)        = returnRn (HsArity arity, emptyFVs)
 675 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update, emptyFVs)
 676 rnIdInfo (HsNoCafRefs)          = returnRn (HsNoCafRefs, emptyFVs)
 677 rnIdInfo (HsCprInfo cpr_info)   = returnRn (HsCprInfo cpr_info, emptyFVs)
 678 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body        `thenRn` \ (rule_body', fvs) ->
 679                                     returnRn (HsSpecialise rule_body', fvs)
 680
 681 rnRuleBody (UfRuleBody str vars args rhs)
 682   = rnCoreBndrs vars            $ \ vars' ->
 683     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs1) ->
 684     rnCoreExpr rhs              `thenRn` \ (rhs',  fvs2) ->
 685     returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
 686 \end{code}
 687
 688 UfCore expressions.
 689
 690 \begin{code}
 691 rnCoreExpr (UfType ty)
 692   = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
 693     returnRn (UfType ty', fvs)
 694
 695 rnCoreExpr (UfVar v)
 696   = lookupOccRn v       `thenRn` \ v' ->
 697     returnRn (UfVar v', unitFV v')
 698
 699 rnCoreExpr (UfCon con args)
 700   = rnUfCon con                 `thenRn` \ (con', fvs1) ->
 701     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs2) ->
 702     returnRn (UfCon con' args', fvs1 `plusFV` fvs2)
 703
 704 rnCoreExpr (UfTuple con args)
 705   = lookupOccRn con             `thenRn` \ con' ->
 706     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs) ->
 707     returnRn (UfTuple con' args', fvs `addOneFV` con')
 708
 709 rnCoreExpr (UfApp fun arg)
 710   = rnCoreExpr fun              `thenRn` \ (fun', fv1) ->
 711     rnCoreExpr arg              `thenRn` \ (arg', fv2) ->
 712     returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
 713
 714 rnCoreExpr (UfCase scrut bndr alts)
 715   = rnCoreExpr scrut                    `thenRn` \ (scrut', fvs1) ->
 716     bindCoreLocalFVRn bndr              ( \ bndr' ->
 717         mapFvRn rnCoreAlt alts          `thenRn` \ (alts', fvs2) ->
 718         returnRn (UfCase scrut' bndr' alts', fvs2)
 719     )                                           `thenRn` \ (case', fvs3) ->
 720     returnRn (case', fvs1 `plusFV` fvs3)
 721
 722 rnCoreExpr (UfNote note expr)
 723   = rnNote note                 `thenRn` \ (note', fvs1) ->
 724     rnCoreExpr expr             `thenRn` \ (expr', fvs2) ->
 725     returnRn  (UfNote note' expr', fvs1 `plusFV` fvs2)
 726
 727 rnCoreExpr (UfLam bndr body)
 728   = rnCoreBndr bndr             $ \ bndr' ->
 729     rnCoreExpr body             `thenRn` \ (body', fvs) ->
 730     returnRn (UfLam bndr' body', fvs)
 731
 732 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 733   = rnCoreExpr rhs              `thenRn` \ (rhs', fvs1) ->
 734     rnCoreBndr bndr             ( \ bndr' ->
 735         rnCoreExpr body         `thenRn` \ (body', fvs2) ->
 736         returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
 737     )                           `thenRn` \ (result, fvs3) ->
 738     returnRn (result, fvs1 `plusFV` fvs3)
 739
 740 rnCoreExpr (UfLet (UfRec pairs) body)
 741   = rnCoreBndrs bndrs           $ \ bndrs' ->
 742     mapFvRn rnCoreExpr rhss     `thenRn` \ (rhss', fvs1) ->
 743     rnCoreExpr body             `thenRn` \ (body', fvs2) ->
 744     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
 745   where
 746     (bndrs, rhss) = unzip pairs
 747 \end{code}
 748
 749 \begin{code}
 750 rnCoreBndr (UfValBinder name ty) thing_inside
 751   = rnHsType doc ty             `thenRn` \ (ty', fvs1) ->
 752     bindCoreLocalFVRn name      ( \ name' ->
 753             thing_inside (UfValBinder name' ty')
 754     )                           `thenRn` \ (result, fvs2) ->
 755     returnRn (result, fvs1 `plusFV` fvs2)
 756   where
 757     doc = text "unfolding id"
 758
 759 rnCoreBndr (UfTyBinder name kind) thing_inside
 760   = bindCoreLocalFVRn name              $ \ name' ->
 761     thing_inside (UfTyBinder name' kind)
 762
 763 rnCoreBndrs []     thing_inside = thing_inside []
 764 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 765                                   rnCoreBndrs bs        $ \ names' ->
 766                                   thing_inside (name':names')
 767 \end{code}
 768
 769 \begin{code}
 770 rnCoreAlt (con, bndrs, rhs)
 771   = rnUfCon con                         `thenRn` \ (con', fvs1) ->
 772     bindCoreLocalsFVRn bndrs            ( \ bndrs' ->
 773         rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
 774         returnRn ((con', bndrs', rhs'), fvs2)
 775     )                                   `thenRn` \ (result, fvs3) ->
 776     returnRn (result, fvs1 `plusFV` fvs3)
 777
 778 rnNote (UfCoerce ty)
 779   = rnHsType (text "unfolding coerce") ty       `thenRn` \ (ty', fvs) ->
 780     returnRn (UfCoerce ty', fvs)
 781
 782 rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
 783 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
 784 rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
 785
 786
 787 rnUfCon UfDefault
 788   = returnRn (UfDefault, emptyFVs)
 789
 790 rnUfCon (UfDataCon con)
 791   = lookupOccRn con             `thenRn` \ con' ->
 792     returnRn (UfDataCon con', unitFV con')
 793
 794 rnUfCon (UfLitCon lit)
 795   = returnRn (UfLitCon lit, emptyFVs)
 796
 797 rnUfCon (UfLitLitCon lit ty)
 798   = rnHsType (text "litlit") ty         `thenRn` \ (ty', fvs) ->
 799     returnRn (UfLitLitCon lit ty', fvs)
 800
 801 rnUfCon (UfPrimOp op)
 802   = lookupOccRn op              `thenRn` \ op' ->
 803     returnRn (UfPrimOp op', emptyFVs)
 804
 805 rnUfCon (UfCCallOp str is_dyn casm gc)
 806   = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs)
 807 \end{code}
 808
 809 %*********************************************************
 810 %*                                                      *
 811 \subsection{Rule shapes}
 812 %*                                                      *
 813 %*********************************************************
 814
 815 Check the shape of a transformation rule LHS.  Currently
 816 we only allow LHSs of the form (f e1 .. en), where f is
 817 not one of the forall'd variables.
 818
 819 \begin{code}
 820 validRuleLhs foralls lhs
 821   = check lhs
 822   where
 823     check (HsApp e1 e2)                   = check e1
 824     check (HsVar v) | v `notElem` foralls = True
 825     check other                           = False
 826 \end{code}
 827
 828
 829 %*********************************************************
 830 %*                                                      *
 831 \subsection{Errors}
 832 %*                                                      *
 833 %*********************************************************
 834
 835 \begin{code}
 836 derivingNonStdClassErr clas
 837   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 838
 839 classTyVarNotInOpTyErr clas_tyvar sig
 840   = hang (hsep [ptext SLIT("Class type variable"),
 841                        quotes (ppr clas_tyvar),
 842                        ptext SLIT("does not appear in method signature")])
 843          4 (ppr sig)
 844
 845 dupClassAssertWarn ctxt (assertion : dups)
 846   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 847                quotes (pprClassAssertion assertion),
 848                ptext SLIT("in the context:")],
 849          nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
 850
 851 badDataCon name
 852    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 853
 854 forAllWarn doc ty tyvar
 855   | not opt_WarnUnusedMatches = returnRn ()
 856   | otherwise
 857   = getModeRn           `thenRn` \ mode ->
 858     case mode of {
 859 #ifndef DEBUG
 860         InterfaceMode -> returnRn () ;  -- Don't warn of unused tyvars in interface files
 861                                         -- unless DEBUG is on, in which case it is slightly
 862                                         -- informative.  They can arise from mkRhsTyLam,
 863 #endif                                  -- leading to (say)     f :: forall a b. [b] -> [b]
 864         other ->
 865
 866     addWarnRn (
 867       sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 868            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 869       $$
 870       (ptext SLIT("In") <+> doc))
 871     }
 872
 873 forAllErr doc ty tyvar
 874   = addErrRn (
 875       sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
 876            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 877       $$
 878       (ptext SLIT("In") <+> doc))
 879
 880 ctxtErr explicit_forall doc tyvars constraint ty
 881   = sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
 882                    ptext SLIT("does not mention any of"),
 883          if explicit_forall then
 884            nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars))
 885          else
 886            nest 4 (ptext SLIT("the type variables in the type") <+> quotes (ppr ty))
 887     ]
 888     $$
 889     (ptext SLIT("In") <+> doc)
 890
 891 badRuleLhsErr name lhs
 892   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 893          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 894     $$
 895     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 896
 897 badRuleVar name var
 898   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 899          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 900                 ptext SLIT("does not appear on left hand side")]
 901 \end{code}