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, nub )
  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 freeRdrTyVars    :: RdrNameHsType -> [RdrName]
 563 freeRdrTyVars ty =  filter isRdrTyVar (extractHsTyRdrNames ty)
 564
 565 rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 566
 567 rnHsType doc (HsForAllTy Nothing ctxt ty)
 568         -- From source code (no kinds on tyvars)
 569         -- Given the signature  C => T  we universally quantify
 570         -- over FV(T) \ {in-scope-tyvars}
 571   = getLocalNameEnv             `thenRn` \ name_env ->
 572     let
 573         mentioned_in_tau = freeRdrTyVars ty
 574         forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_in_tau
 575     in
 576     checkConstraints False doc forall_tyvars ctxt ty    `thenRn` \ ctxt' ->
 577     rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
 578
 579 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 580         -- Explicit quantification.
 581         -- Check that the forall'd tyvars are a subset of the
 582         -- free tyvars in the tau-type part
 583         -- That's only a warning... unless the tyvar is constrained by a
 584         -- context in which case it's an error
 585   = let
 586         mentioned_in_tau  = freeRdrTyVars tau
 587         mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
 588                                       ty <- tys,
 589                                       tv <- freeRdrTyVars ty]
 590
 591         dubious_guys          = filter (`notElem` mentioned_in_tau) forall_tyvar_names
 592                 -- dubious = explicitly quantified but not mentioned in tau type
 593
 594         (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
 595                 -- bad  = explicitly quantified and constrained, but not mentioned in tau
 596                 -- warn = explicitly quantified but not mentioned in ctxt or tau
 597
 598         forall_tyvar_names    = map getTyVarName forall_tyvars
 599     in
 600     mapRn_ (forAllErr doc tau) bad_guys                         `thenRn_`
 601     mapRn_ (forAllWarn doc tau) warn_guys                       `thenRn_`
 602     checkConstraints True doc forall_tyvar_names ctxt tau       `thenRn` \ ctxt' ->
 603     rnForAll doc forall_tyvars ctxt' tau
 604
 605 rnHsType doc (MonoTyVar tyvar)
 606   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 607     returnRn (MonoTyVar tyvar', unitFV tyvar')
 608
 609 rnHsType doc (MonoFunTy ty1 ty2)
 610   = rnHsType doc ty1    `thenRn` \ (ty1', fvs1) ->
 611     rnHsType doc ty2    `thenRn` \ (ty2', fvs2) ->
 612     returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
 613
 614 rnHsType doc (MonoListTy ty)
 615   = rnHsType doc ty                             `thenRn` \ (ty', fvs) ->
 616     returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
 617
 618 rnHsType doc (MonoTupleTy tys boxed)
 619   = rnHsTypes doc tys                   `thenRn` \ (tys', fvs) ->
 620     returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
 621   where
 622     tup_con_name = tupleTyCon_name boxed (length tys)
 623
 624 rnHsType doc (MonoTyApp ty1 ty2)
 625   = rnHsType doc ty1            `thenRn` \ (ty1', fvs1) ->
 626     rnHsType doc ty2            `thenRn` \ (ty2', fvs2) ->
 627     returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
 628
 629 rnHsType doc (MonoDictTy clas tys)
 630   = lookupOccRn clas            `thenRn` \ clas' ->
 631     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 632     returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
 633
 634 rnHsType doc (MonoUsgTy usg ty)
 635   = rnHsType doc ty             `thenRn` \ (ty', fvs) ->
 636     returnRn (MonoUsgTy usg ty', fvs)
 637
 638 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 639 \end{code}
 640
 641
 642 \begin{code}
 643 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 644
 645 rnContext doc ctxt
 646   = mapAndUnzipRn rn_ctxt ctxt          `thenRn` \ (theta, fvs_s) ->
 647     let
 648         (_, dup_asserts) = removeDups cmp_assert theta
 649     in
 650         -- Check for duplicate assertions
 651         -- If this isn't an error, then it ought to be:
 652     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts   `thenRn_`
 653
 654     returnRn (theta, plusFVs fvs_s)
 655   where
 656     rn_ctxt (clas, tys)
 657       = lookupOccRn clas                `thenRn` \ clas_name ->
 658         rnHsTypes doc tys               `thenRn` \ (tys', fvs) ->
 659         returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
 660
 661     cmp_assert (c1,tys1) (c2,tys2)
 662       = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
 663 \end{code}
 664
 665
 666 %*********************************************************
 667 %*                                                      *
 668 \subsection{IdInfo}
 669 %*                                                      *
 670 %*********************************************************
 671
 672 \begin{code}
 673 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
 674
 675 rnIdInfo (HsWorker worker)
 676   = lookupOccRn worker                  `thenRn` \ worker' ->
 677     returnRn (HsWorker worker', unitFV worker')
 678
 679 rnIdInfo (HsUnfold inline (Just expr))  = rnCoreExpr expr       `thenRn` \ (expr', fvs) ->
 680                                           returnRn (HsUnfold inline (Just expr'), fvs)
 681 rnIdInfo (HsUnfold inline Nothing)      = returnRn (HsUnfold inline Nothing, emptyFVs)
 682 rnIdInfo (HsArity arity)        = returnRn (HsArity arity, emptyFVs)
 683 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update, emptyFVs)
 684 rnIdInfo (HsNoCafRefs)          = returnRn (HsNoCafRefs, emptyFVs)
 685 rnIdInfo (HsCprInfo cpr_info)   = returnRn (HsCprInfo cpr_info, emptyFVs)
 686 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body        `thenRn` \ (rule_body', fvs) ->
 687                                     returnRn (HsSpecialise rule_body', fvs)
 688
 689 rnRuleBody (UfRuleBody str vars args rhs)
 690   = rnCoreBndrs vars            $ \ vars' ->
 691     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs1) ->
 692     rnCoreExpr rhs              `thenRn` \ (rhs',  fvs2) ->
 693     returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
 694 \end{code}
 695
 696 UfCore expressions.
 697
 698 \begin{code}
 699 rnCoreExpr (UfType ty)
 700   = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
 701     returnRn (UfType ty', fvs)
 702
 703 rnCoreExpr (UfVar v)
 704   = lookupOccRn v       `thenRn` \ v' ->
 705     returnRn (UfVar v', unitFV v')
 706
 707 rnCoreExpr (UfCon con args)
 708   = rnUfCon con                 `thenRn` \ (con', fvs1) ->
 709     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs2) ->
 710     returnRn (UfCon con' args', fvs1 `plusFV` fvs2)
 711
 712 rnCoreExpr (UfTuple con args)
 713   = lookupOccRn con             `thenRn` \ con' ->
 714     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs) ->
 715     returnRn (UfTuple con' args', fvs `addOneFV` con')
 716
 717 rnCoreExpr (UfApp fun arg)
 718   = rnCoreExpr fun              `thenRn` \ (fun', fv1) ->
 719     rnCoreExpr arg              `thenRn` \ (arg', fv2) ->
 720     returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
 721
 722 rnCoreExpr (UfCase scrut bndr alts)
 723   = rnCoreExpr scrut                    `thenRn` \ (scrut', fvs1) ->
 724     bindCoreLocalFVRn bndr              ( \ bndr' ->
 725         mapFvRn rnCoreAlt alts          `thenRn` \ (alts', fvs2) ->
 726         returnRn (UfCase scrut' bndr' alts', fvs2)
 727     )                                           `thenRn` \ (case', fvs3) ->
 728     returnRn (case', fvs1 `plusFV` fvs3)
 729
 730 rnCoreExpr (UfNote note expr)
 731   = rnNote note                 `thenRn` \ (note', fvs1) ->
 732     rnCoreExpr expr             `thenRn` \ (expr', fvs2) ->
 733     returnRn  (UfNote note' expr', fvs1 `plusFV` fvs2)
 734
 735 rnCoreExpr (UfLam bndr body)
 736   = rnCoreBndr bndr             $ \ bndr' ->
 737     rnCoreExpr body             `thenRn` \ (body', fvs) ->
 738     returnRn (UfLam bndr' body', fvs)
 739
 740 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 741   = rnCoreExpr rhs              `thenRn` \ (rhs', fvs1) ->
 742     rnCoreBndr bndr             ( \ bndr' ->
 743         rnCoreExpr body         `thenRn` \ (body', fvs2) ->
 744         returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
 745     )                           `thenRn` \ (result, fvs3) ->
 746     returnRn (result, fvs1 `plusFV` fvs3)
 747
 748 rnCoreExpr (UfLet (UfRec pairs) body)
 749   = rnCoreBndrs bndrs           $ \ bndrs' ->
 750     mapFvRn rnCoreExpr rhss     `thenRn` \ (rhss', fvs1) ->
 751     rnCoreExpr body             `thenRn` \ (body', fvs2) ->
 752     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
 753   where
 754     (bndrs, rhss) = unzip pairs
 755 \end{code}
 756
 757 \begin{code}
 758 rnCoreBndr (UfValBinder name ty) thing_inside
 759   = rnHsType doc ty             `thenRn` \ (ty', fvs1) ->
 760     bindCoreLocalFVRn name      ( \ name' ->
 761             thing_inside (UfValBinder name' ty')
 762     )                           `thenRn` \ (result, fvs2) ->
 763     returnRn (result, fvs1 `plusFV` fvs2)
 764   where
 765     doc = text "unfolding id"
 766
 767 rnCoreBndr (UfTyBinder name kind) thing_inside
 768   = bindCoreLocalFVRn name              $ \ name' ->
 769     thing_inside (UfTyBinder name' kind)
 770
 771 rnCoreBndrs []     thing_inside = thing_inside []
 772 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 773                                   rnCoreBndrs bs        $ \ names' ->
 774                                   thing_inside (name':names')
 775 \end{code}
 776
 777 \begin{code}
 778 rnCoreAlt (con, bndrs, rhs)
 779   = rnUfCon con                         `thenRn` \ (con', fvs1) ->
 780     bindCoreLocalsFVRn bndrs            ( \ bndrs' ->
 781         rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
 782         returnRn ((con', bndrs', rhs'), fvs2)
 783     )                                   `thenRn` \ (result, fvs3) ->
 784     returnRn (result, fvs1 `plusFV` fvs3)
 785
 786 rnNote (UfCoerce ty)
 787   = rnHsType (text "unfolding coerce") ty       `thenRn` \ (ty', fvs) ->
 788     returnRn (UfCoerce ty', fvs)
 789
 790 rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
 791 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
 792 rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
 793
 794
 795 rnUfCon UfDefault
 796   = returnRn (UfDefault, emptyFVs)
 797
 798 rnUfCon (UfDataCon con)
 799   = lookupOccRn con             `thenRn` \ con' ->
 800     returnRn (UfDataCon con', unitFV con')
 801
 802 rnUfCon (UfLitCon lit)
 803   = returnRn (UfLitCon lit, emptyFVs)
 804
 805 rnUfCon (UfLitLitCon lit ty)
 806   = rnHsType (text "litlit") ty         `thenRn` \ (ty', fvs) ->
 807     returnRn (UfLitLitCon lit ty', fvs)
 808
 809 rnUfCon (UfPrimOp op)
 810   = lookupOccRn op              `thenRn` \ op' ->
 811     returnRn (UfPrimOp op', emptyFVs)
 812
 813 rnUfCon (UfCCallOp str is_dyn casm gc)
 814   = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs)
 815 \end{code}
 816
 817 %*********************************************************
 818 %*                                                      *
 819 \subsection{Rule shapes}
 820 %*                                                      *
 821 %*********************************************************
 822
 823 Check the shape of a transformation rule LHS.  Currently
 824 we only allow LHSs of the form (f e1 .. en), where f is
 825 not one of the forall'd variables.
 826
 827 \begin{code}
 828 validRuleLhs foralls lhs
 829   = check lhs
 830   where
 831     check (HsApp e1 e2)                   = check e1
 832     check (HsVar v) | v `notElem` foralls = True
 833     check other                           = False
 834 \end{code}
 835
 836
 837 %*********************************************************
 838 %*                                                      *
 839 \subsection{Errors}
 840 %*                                                      *
 841 %*********************************************************
 842
 843 \begin{code}
 844 derivingNonStdClassErr clas
 845   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 846
 847 classTyVarNotInOpTyErr clas_tyvar sig
 848   = hang (hsep [ptext SLIT("Class type variable"),
 849                        quotes (ppr clas_tyvar),
 850                        ptext SLIT("does not appear in method signature")])
 851          4 (ppr sig)
 852
 853 dupClassAssertWarn ctxt (assertion : dups)
 854   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 855                quotes (pprClassAssertion assertion),
 856                ptext SLIT("in the context:")],
 857          nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
 858
 859 badDataCon name
 860    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 861
 862 forAllWarn doc ty tyvar
 863   | not opt_WarnUnusedMatches = returnRn ()
 864   | otherwise
 865   = getModeRn           `thenRn` \ mode ->
 866     case mode of {
 867 #ifndef DEBUG
 868         InterfaceMode -> returnRn () ;  -- Don't warn of unused tyvars in interface files
 869                                         -- unless DEBUG is on, in which case it is slightly
 870                                         -- informative.  They can arise from mkRhsTyLam,
 871 #endif                                  -- leading to (say)     f :: forall a b. [b] -> [b]
 872         other ->
 873
 874     addWarnRn (
 875       sep [ptext SLIT("The universally quantified 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
 881 forAllErr doc ty tyvar
 882   = addErrRn (
 883       sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
 884            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 885       $$
 886       (ptext SLIT("In") <+> doc))
 887
 888 ctxtErr explicit_forall doc tyvars constraint ty
 889   = sep [ptext SLIT("None of the type variable(s) in the constraint") <+> quotes (pprClassAssertion constraint),
 890          if explicit_forall then
 891            nest 4 (ptext SLIT("is universally quantified (i.e. bound by the forall)"))
 892          else
 893            nest 4 (ptext SLIT("appears in the type") <+> quotes (ppr ty))
 894     ]
 895     $$
 896     (ptext SLIT("In") <+> doc)
 897
 898 badRuleLhsErr name lhs
 899   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 900          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 901     $$
 902     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 903
 904 badRuleVar name var
 905   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 906          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 907                 ptext SLIT("does not appear on left hand side")]
 908 \end{code}