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 (
   8         rnSrcDecls, addTcgDUs, rnTyClDecls
   9     ) where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} RnExpr( rnLExpr )
  14
  15 import HsSyn
  16 import RdrName          ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
  17 import RdrHsSyn         ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
  18 import RnHsSyn
  19 import RnTypes          ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
  20 import RnBinds          ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
  21                                 makeMiniFixityEnv)
  22 import RnEnv            ( lookupLocalDataTcNames, lookupLocatedOccRn,
  23                           lookupTopBndrRn, lookupLocatedTopBndrRn,
  24                           lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
  25                           bindLocatedLocalsFV, bindPatSigTyVarsFV,
  26                           bindTyVarsRn, extendTyVarEnvFVRn,
  27                           bindLocalNames, checkDupRdrNames, mapFvRn
  28                         )
  29 import RnNames          ( getLocalNonValBinders, extendGlobalRdrEnvRn )
  30 import HscTypes         ( GenAvailInfo(..), availsToNameSet )
  31 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
  32 import TcRnMonad
  33
  34 import ForeignCall      ( CCallTarget(..) )
  35 import Module
  36 import HscTypes         ( Warnings(..), plusWarns )
  37 import Class            ( FunDep )
  38 import Name             ( Name, nameOccName )
  39 import NameSet
  40 import NameEnv
  41 import Outputable
  42 import Bag
  43 import FastString
  44 import Util             ( filterOut )
  45 import SrcLoc
  46 import DynFlags         ( DynFlag(..), DynFlags, thisPackage )
  47 import HscTypes         ( HscEnv, hsc_dflags )
  48 import BasicTypes       ( Boxity(..) )
  49 import ListSetOps       ( findDupsEq )
  50
  51
  52 import Control.Monad
  53 import Data.Maybe
  54 \end{code}
  55
  56 \begin{code}
  57 -- XXX
  58 thenM :: Monad a => a b -> (b -> a c) -> a c
  59 thenM = (>>=)
  60
  61 thenM_ :: Monad a => a b -> a c -> a c
  62 thenM_ = (>>)
  63 \end{code}
  64
  65 @rnSourceDecl@ `renames' declarations.
  66 It simultaneously performs dependency analysis and precedence parsing.
  67 It also does the following error checks:
  68 \begin{enumerate}
  69 \item
  70 Checks that tyvars are used properly. This includes checking
  71 for undefined tyvars, and tyvars in contexts that are ambiguous.
  72 (Some of this checking has now been moved to module @TcMonoType@,
  73 since we don't have functional dependency information at this point.)
  74 \item
  75 Checks that all variable occurences are defined.
  76 \item
  77 Checks the @(..)@ etc constraints in the export list.
  78 \end{enumerate}
  79
  80
  81 \begin{code}
  82 -- Brings the binders of the group into scope in the appropriate places;
  83 -- does NOT assume that anything is in scope already
  84 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
  85 -- Rename a HsGroup; used for normal source files *and* hs-boot files
  86 rnSrcDecls group@(HsGroup {hs_valds  = val_decls,
  87                                    hs_tyclds = tycl_decls,
  88                                    hs_instds = inst_decls,
  89                                    hs_derivds = deriv_decls,
  90                                    hs_fixds  = fix_decls,
  91                                    hs_warnds  = warn_decls,
  92                                    hs_annds  = ann_decls,
  93                                    hs_fords  = foreign_decls,
  94                                    hs_defds  = default_decls,
  95                                    hs_ruleds = rule_decls,
  96                                    hs_docs   = docs })
  97  = do {
  98    -- (A) Process the fixity declarations, creating a mapping from
  99    --     FastStrings to FixItems.
 100    --     Also checks for duplcates.
 101    local_fix_env <- makeMiniFixityEnv fix_decls;
 102
 103    -- (B) Bring top level binders (and their fixities) into scope,
 104    --     *except* for the value bindings, which get brought in below.
 105    --     However *do* include class ops, data constructors
 106    --     And for hs-boot files *do* include the value signatures
 107    tc_avails <- getLocalNonValBinders group ;
 108    tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ;
 109    setEnvs tc_envs $ do {
 110
 111    failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
 112
 113    -- (C) Extract the mapping from data constructors to field names and
 114    --     extend the record field env.
 115    --     This depends on the data constructors and field names being in
 116    --     scope from (B) above
 117    inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
 118
 119    -- (D) Rename the left-hand sides of the value bindings.
 120    --     This depends on everything from (B) being in scope,
 121    --     and on (C) for resolving record wild cards.
 122    --     It uses the fixity env from (A) to bind fixities for view patterns.
 123    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
 124    -- bind the LHSes (and their fixities) in the global rdr environment
 125    let { val_binders = map unLoc $ collectHsValBinders new_lhs ;
 126          val_bndr_set = mkNameSet val_binders ;
 127          all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
 128          val_avails = map Avail val_binders
 129        } ;
 130    (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
 131    setEnvs (tcg_env, tcl_env) $ do {
 132
 133    --  Now everything is in scope, as the remaining renaming assumes.
 134
 135    -- (E) Rename type and class decls
 136    --     (note that value LHSes need to be in scope for default methods)
 137    --
 138    -- You might think that we could build proper def/use information
 139    -- for type and class declarations, but they can be involved
 140    -- in mutual recursion across modules, and we only do the SCC
 141    -- analysis for them in the type checker.
 142    -- So we content ourselves with gathering uses only; that
 143    -- means we'll only report a declaration as unused if it isn't
 144    -- mentioned at all.  Ah well.
 145    traceRn (text "Start rnTyClDecls") ;
 146    (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
 147
 148    -- (F) Rename Value declarations right-hand sides
 149    traceRn (text "Start rnmono") ;
 150    (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ;
 151    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
 152
 153    -- (G) Rename Fixity and deprecations
 154
 155    -- Rename fixity declarations and error if we try to
 156    -- fix something from another module (duplicates were checked in (A))
 157    rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
 158
 159    -- Rename deprec decls;
 160    -- check for duplicates and ensure that deprecated things are defined locally
 161    -- at the moment, we don't keep these around past renaming
 162    rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
 163
 164    -- (H) Rename Everything else
 165
 166    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
 167    (rn_rule_decls,    src_fvs3) <- setOptM Opt_ScopedTypeVariables $
 168                                    rnList rnHsRuleDecl    rule_decls ;
 169                            -- Inside RULES, scoped type variables are on
 170    (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
 171    (rn_ann_decls,     src_fvs5) <- rnList rnAnnDecl       ann_decls ;
 172    (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl   default_decls ;
 173    (rn_deriv_decls,   src_fvs7) <- rnList rnSrcDerivDecl  deriv_decls ;
 174       -- Haddock docs; no free vars
 175    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 176
 177    -- (I) Compute the results and return
 178    let {rn_group = HsGroup { hs_valds  = rn_val_decls,
 179                              hs_tyclds = rn_tycl_decls,
 180                              hs_instds = rn_inst_decls,
 181                              hs_derivds = rn_deriv_decls,
 182                              hs_fixds  = rn_fix_decls,
 183                              hs_warnds = [], -- warns are returned in the tcg_env
 184                                              -- (see below) not in the HsGroup
 185                              hs_fords  = rn_foreign_decls,
 186                              hs_annds   = rn_ann_decls,
 187                              hs_defds  = rn_default_decls,
 188                              hs_ruleds = rn_rule_decls,
 189                              hs_docs   = rn_docs } ;
 190
 191         other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
 192                              src_fvs5, src_fvs6, src_fvs7] ;
 193         src_dus = bind_dus `plusDU` usesOnly other_fvs;
 194                 -- Note: src_dus will contain *uses* for locally-defined types
 195                 -- and classes, but no *defs* for them.  (Because rnTyClDecl
 196                 -- returns only the uses.)  This is a little
 197                 -- surprising but it doesn't actually matter at all.
 198
 199        final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
 200                        in -- we return the deprecs in the env, not in the HsGroup above
 201                          tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
 202        } ;
 203
 204    traceRn (text "finish rnSrc" <+> ppr rn_group) ;
 205    traceRn (text "finish Dus" <+> ppr src_dus ) ;
 206    return (final_tcg_env , rn_group)
 207                     }}}}
 208
 209 -- some utils because we do this a bunch above
 210 -- compute and install the new env
 211 inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
 212 inNewEnv env cont = do e <- env
 213                        setGblEnv e $ cont e
 214
 215 rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
 216 -- Used for external core
 217 rnTyClDecls tycl_decls = do  (decls', _fvs) <- rnList rnTyClDecl tycl_decls
 218                              return decls'
 219
 220 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
 221 -- This function could be defined lower down in the module hierarchy,
 222 -- but there doesn't seem anywhere very logical to put it.
 223 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
 224
 225 rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
 226 rnList f xs = mapFvRn (wrapLocFstM f) xs
 227 \end{code}
 228
 229
 230 %*********************************************************
 231 %*                                                       *
 232         HsDoc stuff
 233 %*                                                       *
 234 %*********************************************************
 235
 236 \begin{code}
 237 rnDocDecl :: DocDecl -> RnM DocDecl
 238 rnDocDecl (DocCommentNext doc) = do
 239   rn_doc <- rnHsDoc doc
 240   return (DocCommentNext rn_doc)
 241 rnDocDecl (DocCommentPrev doc) = do
 242   rn_doc <- rnHsDoc doc
 243   return (DocCommentPrev rn_doc)
 244 rnDocDecl (DocCommentNamed str doc) = do
 245   rn_doc <- rnHsDoc doc
 246   return (DocCommentNamed str rn_doc)
 247 rnDocDecl (DocGroup lev doc) = do
 248   rn_doc <- rnHsDoc doc
 249   return (DocGroup lev rn_doc)
 250 \end{code}
 251
 252
 253 %*********************************************************
 254 %*                                                       *
 255         Source-code fixity declarations
 256 %*                                                       *
 257 %*********************************************************
 258
 259 \begin{code}
 260 rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
 261 -- Rename the fixity decls, so we can put
 262 -- the renamed decls in the renamed syntax tree
 263 -- Errors if the thing being fixed is not defined locally.
 264 --
 265 -- The returned FixitySigs are not actually used for anything,
 266 -- except perhaps the GHCi API
 267 rnSrcFixityDecls bound_names fix_decls
 268   = do fix_decls <- mapM rn_decl fix_decls
 269        return (concat fix_decls)
 270   where
 271     rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
 272         -- GHC extension: look up both the tycon and data con
 273         -- for con-like things; hence returning a list
 274         -- If neither are in scope, report an error; otherwise
 275         -- return a fixity sig for each (slightly odd)
 276     rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
 277       = setSrcSpan name_loc $
 278                     -- this lookup will fail if the definition isn't local
 279         do names <- lookupLocalDataTcNames bound_names what rdr_name
 280            return [ L loc (FixitySig (L name_loc name) fixity)
 281                   | name <- names ]
 282     what = ptext (sLit "fixity signature")
 283 \end{code}
 284
 285
 286 %*********************************************************
 287 %*                                                       *
 288         Source-code deprecations declarations
 289 %*                                                       *
 290 %*********************************************************
 291
 292 Check that the deprecated names are defined, are defined locally, and
 293 that there are no duplicate deprecations.
 294
 295 It's only imported deprecations, dealt with in RnIfaces, that we
 296 gather them together.
 297
 298 \begin{code}
 299 -- checks that the deprecations are defined locally, and that there are no duplicates
 300 rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
 301 rnSrcWarnDecls _bound_names []
 302   = return NoWarnings
 303
 304 rnSrcWarnDecls bound_names decls
 305   = do { -- check for duplicates
 306        ; mapM_ (\ (L loc rdr:lrdr':_) -> addErrAt loc (dupWarnDecl lrdr' rdr))
 307                warn_rdr_dups
 308        ; pairs_s <- mapM (addLocM rn_deprec) decls
 309        ; return (WarnSome ((concat pairs_s))) }
 310  where
 311    rn_deprec (Warning rdr_name txt)
 312        -- ensures that the names are defined locally
 313      = lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names ->
 314        return [(nameOccName name, txt) | name <- names]
 315
 316    what = ptext (sLit "deprecation")
 317
 318    -- look for duplicates among the OccNames;
 319    -- we check that the names are defined above
 320    -- invt: the lists returned by findDupsEq always have at least two elements
 321    warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
 322                      (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
 323
 324 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
 325 -- Located RdrName -> DeprecDecl RdrName -> SDoc
 326 dupWarnDecl (L loc _) rdr_name
 327   = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
 328           ptext (sLit "also at ") <+> ppr loc]
 329
 330 \end{code}
 331
 332 %*********************************************************
 333 %*                                                      *
 334 \subsection{Annotation declarations}
 335 %*                                                      *
 336 %*********************************************************
 337
 338 \begin{code}
 339 rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
 340 rnAnnDecl (HsAnnotation provenance expr) = do
 341     (provenance', provenance_fvs) <- rnAnnProvenance provenance
 342     (expr', expr_fvs) <- rnLExpr expr
 343     return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs)
 344
 345 rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
 346 rnAnnProvenance provenance = do
 347     provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance
 348     return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
 349 \end{code}
 350
 351 %*********************************************************
 352 %*                                                      *
 353 \subsection{Default declarations}
 354 %*                                                      *
 355 %*********************************************************
 356
 357 \begin{code}
 358 rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
 359 rnDefaultDecl (DefaultDecl tys)
 360   = mapFvRn (rnHsTypeFVs doc_str) tys   `thenM` \ (tys', fvs) ->
 361     return (DefaultDecl tys', fvs)
 362   where
 363     doc_str = text "In a `default' declaration"
 364 \end{code}
 365
 366 %*********************************************************
 367 %*                                                      *
 368 \subsection{Foreign declarations}
 369 %*                                                      *
 370 %*********************************************************
 371
 372 \begin{code}
 373 rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
 374 rnHsForeignDecl (ForeignImport name ty spec)
 375   = getTopEnv                           `thenM` \ (topEnv :: HscEnv) ->
 376     lookupLocatedTopBndrRn name         `thenM` \ name' ->
 377     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 378
 379     -- Mark any PackageTarget style imports as coming from the current package
 380     let packageId       = thisPackage $ hsc_dflags topEnv
 381         spec'           = patchForeignImport packageId spec
 382
 383     in  return (ForeignImport name' ty' spec', fvs)
 384
 385 rnHsForeignDecl (ForeignExport name ty spec)
 386   = lookupLocatedOccRn name             `thenM` \ name' ->
 387     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 388     return (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name')
 389         -- NB: a foreign export is an *occurrence site* for name, so
 390         --     we add it to the free-variable list.  It might, for example,
 391         --     be imported from another module
 392
 393 fo_decl_msg :: Located RdrName -> SDoc
 394 fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
 395
 396
 397 -- | For Windows DLLs we need to know what packages imported symbols are from
 398 --      to generate correct calls. Imported symbols are tagged with the current
 399 --      package, so if they get inlined across a package boundry we'll still
 400 --      know where they're from.
 401 --
 402 patchForeignImport :: PackageId -> ForeignImport -> ForeignImport
 403 patchForeignImport packageId (CImport cconv safety fs spec)
 404         = CImport cconv safety fs (patchCImportSpec packageId spec)
 405
 406 patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec
 407 patchCImportSpec packageId spec
 408  = case spec of
 409         CFunction callTarget    -> CFunction $ patchCCallTarget packageId callTarget
 410         _                       -> spec
 411
 412 patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
 413 patchCCallTarget packageId callTarget
 414  = case callTarget of
 415         StaticTarget label Nothing
 416          -> StaticTarget label (Just packageId)
 417
 418         _                       -> callTarget
 419
 420
 421 \end{code}
 422
 423
 424 %*********************************************************
 425 %*                                                      *
 426 \subsection{Instance declarations}
 427 %*                                                      *
 428 %*********************************************************
 429
 430 \begin{code}
 431 rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
 432 rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 433         -- Used for both source and interface file decls
 434   = rnHsSigType (text "an instance decl") inst_ty       `thenM` \ inst_ty' ->
 435
 436         -- Rename the bindings
 437         -- The typechecker (not the renamer) checks that all
 438         -- the bindings are for the right class
 439     let
 440         meth_names  = collectHsBindLocatedBinders mbinds
 441         (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
 442     in
 443     checkDupRdrNames meth_names         `thenM_`
 444         -- Check that the same method is not given twice in the
 445         -- same instance decl   instance C T where
 446         --                            f x = ...
 447         --                            g y = ...
 448         --                            f x = ...
 449         -- We must use checkDupRdrNames because the Name of the
 450         -- method is the Name of the class selector, whose SrcSpan
 451         -- points to the class declaration
 452
 453     extendTyVarEnvForMethodBinds inst_tyvars (
 454         -- (Slightly strangely) the forall-d tyvars scope over
 455         -- the method bindings too
 456         rnMethodBinds cls (\_ -> [])    -- No scoped tyvars
 457                       [] mbinds
 458     )                                           `thenM` \ (mbinds', meth_fvs) ->
 459         -- Rename the associated types
 460         -- The typechecker (not the renamer) checks that all
 461         -- the declarations are for the right class
 462     let
 463         at_names = map (head . tyClDeclNames . unLoc) ats
 464     in
 465     checkDupRdrNames at_names           `thenM_`
 466         -- See notes with checkDupRdrNames for methods, above
 467
 468     rnATInsts ats                               `thenM` \ (ats', at_fvs) ->
 469
 470         -- Rename the prags and signatures.
 471         -- Note that the type variables are not in scope here,
 472         -- so that      instance Eq a => Eq (T a) where
 473         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 474         -- works OK.
 475         --
 476         -- But the (unqualified) method names are in scope
 477     let
 478         binders = collectHsBindBinders mbinds'
 479         bndr_set = mkNameSet binders
 480     in
 481     bindLocalNames binders
 482         (renameSigs (Just bndr_set) okInstDclSig uprags)        `thenM` \ uprags' ->
 483
 484     return (InstDecl inst_ty' mbinds' uprags' ats',
 485              meth_fvs `plusFV` at_fvs
 486                       `plusFV` hsSigsFVs uprags'
 487                       `plusFV` extractHsTyNames inst_ty')
 488              -- We return the renamed associated data type declarations so
 489              -- that they can be entered into the list of type declarations
 490              -- for the binding group, but we also keep a copy in the instance.
 491              -- The latter is needed for well-formedness checks in the type
 492              -- checker (eg, to ensure that all ATs of the instance actually
 493              -- receive a declaration).
 494              -- NB: Even the copies in the instance declaration carry copies of
 495              --     the instance context after renaming.  This is a bit
 496              --     strange, but should not matter (and it would be more work
 497              --     to remove the context).
 498 \end{code}
 499
 500 Renaming of the associated types in instances.
 501
 502 \begin{code}
 503 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 504 rnATInsts atDecls = rnList rnATInst atDecls
 505   where
 506     rnATInst tydecl@TyData     {} = rnTyClDecl tydecl
 507     rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
 508     rnATInst tydecl               =
 509       pprPanic "RnSource.rnATInsts: invalid AT instance"
 510                (ppr (tcdName tydecl))
 511 \end{code}
 512
 513 For the method bindings in class and instance decls, we extend the
 514 type variable environment iff -fglasgow-exts
 515
 516 \begin{code}
 517 extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
 518                              -> RnM (Bag (LHsBind Name), FreeVars)
 519                              -> RnM (Bag (LHsBind Name), FreeVars)
 520 extendTyVarEnvForMethodBinds tyvars thing_inside
 521   = do  { scoped_tvs <- doptM Opt_ScopedTypeVariables
 522         ; if scoped_tvs then
 523                 extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
 524           else
 525                 thing_inside }
 526 \end{code}
 527
 528 %*********************************************************
 529 %*                                                      *
 530 \subsection{Stand-alone deriving declarations}
 531 %*                                                      *
 532 %*********************************************************
 533
 534 \begin{code}
 535 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
 536 rnSrcDerivDecl (DerivDecl ty)
 537   = do { standalone_deriv_ok <- doptM Opt_StandaloneDeriving
 538        ; unless standalone_deriv_ok (addErr standaloneDerivErr)
 539        ; ty' <- rnLHsType (text "a deriving decl") ty
 540        ; let fvs = extractHsTyNames ty'
 541        ; return (DerivDecl ty', fvs) }
 542
 543 standaloneDerivErr :: SDoc
 544 standaloneDerivErr
 545   = hang (ptext (sLit "Illegal standalone deriving declaration"))
 546        2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
 547 \end{code}
 548
 549 %*********************************************************
 550 %*                                                      *
 551 \subsection{Rules}
 552 %*                                                      *
 553 %*********************************************************
 554
 555 \begin{code}
 556 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
 557 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
 558   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
 559     bindLocatedLocalsFV (map get_var vars)              $ \ ids ->
 560     do  { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
 561                 -- NB: The binders in a rule are always Ids
 562                 --     We don't (yet) support type variables
 563
 564         ; (lhs', fv_lhs') <- rnLExpr lhs
 565         ; (rhs', fv_rhs') <- rnLExpr rhs
 566
 567         ; checkValidRule rule_name ids lhs' fv_lhs'
 568
 569         ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
 570                   fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
 571   where
 572     doc = text "In the transformation rule" <+> ftext rule_name
 573
 574     get_var (RuleBndr v)      = v
 575     get_var (RuleBndrSig v _) = v
 576
 577     rn_var (RuleBndr (L loc _), id)
 578         = return (RuleBndr (L loc id), emptyFVs)
 579     rn_var (RuleBndrSig (L loc _) t, id)
 580         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
 581           return (RuleBndrSig (L loc id) t', fvs)
 582
 583 badRuleVar :: FastString -> Name -> SDoc
 584 badRuleVar name var
 585   = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
 586          ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
 587                 ptext (sLit "does not appear on left hand side")]
 588 \end{code}
 589
 590 Note [Rule LHS validity checking]
 591 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 592 Check the shape of a transformation rule LHS.  Currently we only allow
 593 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
 594 @forall@'d variables.
 595
 596 We used restrict the form of the 'ei' to prevent you writing rules
 597 with LHSs with a complicated desugaring (and hence unlikely to match);
 598 (e.g. a case expression is not allowed: too elaborate.)
 599
 600 But there are legitimate non-trivial args ei, like sections and
 601 lambdas.  So it seems simmpler not to check at all, and that is why
 602 check_e is commented out.
 603
 604 \begin{code}
 605 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
 606 checkValidRule rule_name ids lhs' fv_lhs'
 607   = do  {       -- Check for the form of the LHS
 608           case (validRuleLhs ids lhs') of
 609                 Nothing  -> return ()
 610                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
 611
 612                 -- Check that LHS vars are all bound
 613         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
 614         ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
 615
 616 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 617 -- Nothing => OK
 618 -- Just e  => Not ok, and e is the offending expression
 619 validRuleLhs foralls lhs
 620   = checkl lhs
 621   where
 622     checkl (L _ e) = check e
 623
 624     check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
 625     check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
 626     check (HsVar v) | v `notElem` foralls = Nothing
 627     check other                           = Just other  -- Failure
 628
 629         -- Check an argument
 630     checkl_e (L _ _e) = Nothing         -- Was (check_e e); see Note [Rule LHS validity checking]
 631
 632 {-      Commented out; see Note [Rule LHS validity checking] above
 633     check_e (HsVar v)     = Nothing
 634     check_e (HsPar e)     = checkl_e e
 635     check_e (HsLit e)     = Nothing
 636     check_e (HsOverLit e) = Nothing
 637
 638     check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
 639     check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
 640     check_e (NegApp e _)         = checkl_e e
 641     check_e (ExplicitList _ es)  = checkl_es es
 642     check_e other                = Just other   -- Fails
 643
 644     checkl_es es = foldr (mplus . checkl_e) Nothing es
 645 -}
 646
 647 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
 648 badRuleLhsErr name lhs bad_e
 649   = sep [ptext (sLit "Rule") <+> ftext name <> colon,
 650          nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e,
 651                        ptext (sLit "in left-hand side:") <+> ppr lhs])]
 652     $$
 653     ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
 654 \end{code}
 655
 656
 657 %*********************************************************
 658 %*                                                      *
 659 \subsection{Type, class and iface sig declarations}
 660 %*                                                      *
 661 %*********************************************************
 662
 663 @rnTyDecl@ uses the `global name function' to create a new type
 664 declaration in which local names have been replaced by their original
 665 names, reporting any unknown names.
 666
 667 Renaming type variables is a pain. Because they now contain uniques,
 668 it is necessary to pass in an association list which maps a parsed
 669 tyvar to its @Name@ representation.
 670 In some cases (type signatures of values),
 671 it is even necessary to go over the type first
 672 in order to get the set of tyvars used by it, make an assoc list,
 673 and then go over it again to rename the tyvars!
 674 However, we can also do some scoping checks at the same time.
 675
 676 \begin{code}
 677 rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
 678 rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
 679   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 680     return (ForeignType {tcdLName = name', tcdExtName = ext_name},
 681              emptyFVs)
 682
 683 -- all flavours of type family declarations ("type family", "newtype fanily",
 684 -- and "data family")
 685 rnTyClDecl (tydecl@TyFamily {}) =
 686   rnFamily tydecl bindTyVarsRn
 687
 688 -- "data", "newtype", "data instance, and "newtype instance" declarations
 689 rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 690                            tcdLName = tycon, tcdTyVars = tyvars,
 691                            tcdTyPats = typatsMaybe, tcdCons = condecls,
 692                            tcdKindSig = sig, tcdDerivs = derivs}
 693   = do  { tycon' <- if isFamInstDecl tydecl
 694                     then lookupLocatedOccRn     tycon -- may be imported family
 695                     else lookupLocatedTopBndrRn tycon
 696         ; checkTc (h98_style || null (unLoc context))
 697                   (badGadtStupidTheta tycon)
 698         ; (tyvars', context', typats', derivs', deriv_fvs)
 699                 <- bindTyVarsRn tyvars $ \ tyvars' -> do
 700                                  -- Checks for distinct tyvars
 701                    { typats' <- rnTyPats data_doc typatsMaybe
 702                    ; context' <- rnContext data_doc context
 703                    ; (derivs', deriv_fvs) <- rn_derivs derivs
 704                    ; return (tyvars', context', typats', derivs', deriv_fvs) }
 705                 -- For GADTs, the type variables in the declaration
 706                 -- do not scope over the constructor signatures
 707                 --      data T a where { T1 :: forall b. b-> b }
 708
 709         -- For the constructor declarations, bring into scope the tyvars
 710         -- bound by the header, but *only* in the H98 case
 711         ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
 712                               | otherwise = []
 713         ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
 714                                   rnConDecls condecls
 715                 -- No need to check for duplicate constructor decls
 716                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 717
 718         ; return (TyData {tcdND = new_or_data, tcdCtxt = context',
 719                            tcdLName = tycon', tcdTyVars = tyvars',
 720                            tcdTyPats = typats', tcdKindSig = sig,
 721                            tcdCons = condecls', tcdDerivs = derivs'},
 722                    con_fvs              `plusFV`
 723                    deriv_fvs            `plusFV`
 724                    (if isFamInstDecl tydecl
 725                    then unitFV (unLoc tycon')   -- type instance => use
 726                    else emptyFVs))
 727         }
 728   where
 729     h98_style = case condecls of         -- Note [Stupid theta]
 730                      L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
 731                      _                                             -> True
 732
 733     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 734
 735     rn_derivs Nothing   = return (Nothing, emptyFVs)
 736     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 737                           return (Just ds', extractHsTyNames_s ds')
 738
 739 -- "type" and "type instance" declarations
 740 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
 741                               tcdTyPats = typatsMaybe, tcdSynRhs = ty})
 742   = bindTyVarsRn tyvars $ \ tyvars' -> do
 743     {            -- Checks for distinct tyvars
 744       name' <- if isFamInstDecl tydecl
 745                   then lookupLocatedOccRn     name -- may be imported family
 746                   else lookupLocatedTopBndrRn name
 747     ; typats' <- rnTyPats syn_doc typatsMaybe
 748     ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
 749     ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
 750                         , tcdTyPats = typats', tcdSynRhs = ty'},
 751               delFVs (map hsLTyVarName tyvars') $
 752               fvs                             `plusFV`
 753                (if isFamInstDecl tydecl
 754                then unitFV (unLoc name')        -- type instance => use
 755                else emptyFVs))
 756     }
 757   where
 758     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 759
 760 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 761                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 762                        tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
 763   = do  { cname' <- lookupLocatedTopBndrRn cname
 764
 765         -- Tyvars scope over superclass context and method signatures
 766         ; (tyvars', context', fds', ats', ats_fvs, sigs')
 767             <- bindTyVarsRn tyvars $ \ tyvars' -> do
 768                  -- Checks for distinct tyvars
 769              { context' <- rnContext cls_doc context
 770              ; fds' <- rnFds cls_doc fds
 771              ; (ats', ats_fvs) <- rnATs ats
 772              ; sigs' <- renameSigs Nothing okClsDclSig sigs
 773              ; return   (tyvars', context', fds', ats', ats_fvs, sigs') }
 774
 775         -- No need to check for duplicate associated type decls
 776         -- since that is done by RnNames.extendGlobalRdrEnvRn
 777
 778         -- Check the signatures
 779         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 780         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
 781         ; checkDupRdrNames sig_rdr_names_w_locs
 782                 -- Typechecker is responsible for checking that we only
 783                 -- give default-method bindings for things in this class.
 784                 -- The renamer *could* check this for class decls, but can't
 785                 -- for instance decls.
 786
 787         -- The newLocals call is tiresome: given a generic class decl
 788         --      class C a where
 789         --        op :: a -> a
 790         --        op {| x+y |} (Inl a) = ...
 791         --        op {| x+y |} (Inr b) = ...
 792         --        op {| a*b |} (a*b)   = ...
 793         -- we want to name both "x" tyvars with the same unique, so that they are
 794         -- easy to group together in the typechecker.
 795         ; (mbinds', meth_fvs)
 796             <- extendTyVarEnvForMethodBinds tyvars' $ do
 797             { name_env <- getLocalRdrEnv
 798             ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
 799                                                  not (unLoc tv `elemLocalRdrEnv` name_env) ]
 800                 -- No need to check for duplicate method signatures
 801                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 802                 -- and the methods are already in scope
 803             ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
 804             ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
 805
 806   -- Haddock docs
 807         ; docs' <- mapM (wrapLocM rnDocDecl) docs
 808
 809         ; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
 810                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
 811                               tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
 812
 813                   delFVs (map hsLTyVarName tyvars')     $
 814                   extractHsCtxtTyNames context'         `plusFV`
 815                   plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
 816                   hsSigsFVs sigs'                       `plusFV`
 817                   meth_fvs                              `plusFV`
 818                   ats_fvs) }
 819   where
 820     cls_doc  = text "In the declaration for class"      <+> ppr cname
 821
 822 badGadtStupidTheta :: Located RdrName -> SDoc
 823 badGadtStupidTheta _
 824   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
 825           ptext (sLit "(You can put a context on each contructor, though.)")]
 826 \end{code}
 827
 828 Note [Stupid theta]
 829 ~~~~~~~~~~~~~~~~~~~
 830 Trac #3850 complains about a regression wrt 6.10 for
 831      data Show a => T a
 832 There is no reason not to allow the stupid theta if there are no data
 833 constructors.  It's still stupid, but does no harm, and I don't want
 834 to cause programs to break unnecessarily (notably HList).  So if there
 835 are no data constructors we allow h98_style = True
 836
 837
 838 %*********************************************************
 839 %*                                                      *
 840 \subsection{Support code for type/data declarations}
 841 %*                                                      *
 842 %*********************************************************
 843
 844 \begin{code}
 845 rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
 846 -- Although, we are processing type patterns here, all type variables will
 847 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 848 -- type declaration to which these patterns belong)
 849 rnTyPats _   Nothing       = return Nothing
 850 rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
 851
 852 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
 853 rnConDecls condecls
 854   = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
 855        ; return (condecls', plusFVs (map conDeclFVs condecls')) }
 856
 857 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 858 rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
 859                                , con_cxt = cxt, con_details = details
 860                                , con_res = res_ty, con_doc = mb_doc
 861                                , con_old_rec = old_rec, con_explicit = expl })
 862   = do  { addLocM checkConName name
 863         ; when old_rec (addWarn (deprecRecSyntax decl))
 864         ; new_name <- lookupLocatedTopBndrRn name
 865
 866            -- For H98 syntax, the tvs are the existential ones
 867            -- For GADT syntax, the tvs are all the quantified tyvars
 868            -- Hence the 'filter' in the ResTyH98 case only
 869         ; rdr_env <- getLocalRdrEnv
 870         ; let in_scope     = (`elemLocalRdrEnv` rdr_env) . unLoc
 871               arg_tys      = hsConDeclArgTys details
 872               implicit_tvs = case res_ty of
 873                                ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
 874                                ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 875               new_tvs = case expl of
 876                           Explicit -> tvs
 877                           Implicit -> userHsTyVarBndrs implicit_tvs
 878
 879         ; mb_doc' <- rnMbLHsDoc mb_doc
 880
 881         ; bindTyVarsRn new_tvs $ \new_tyvars -> do
 882         { new_context <- rnContext doc cxt
 883         ; new_details <- rnConDeclDetails doc details
 884         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
 885         ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
 886                        , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
 887  where
 888     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 889     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 890
 891 rnConResult :: SDoc
 892             -> HsConDetails (LHsType Name) [ConDeclField Name]
 893             -> ResType RdrName
 894             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
 895                     ResType Name)
 896 rnConResult _ details ResTyH98 = return (details, ResTyH98)
 897 rnConResult doc details (ResTyGADT ty)
 898   = do { ty' <- rnLHsType doc ty
 899        ; let (arg_tys, res_ty) = splitHsFunType ty'
 900                 -- We can finally split it up,
 901                 -- now the renamer has dealt with fixities
 902                 -- See Note [Sorting out the result type] in RdrHsSyn
 903
 904              details' = case details of
 905                            RecCon {}    -> details
 906                            PrefixCon {} -> PrefixCon arg_tys
 907                            InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
 908                           -- See Note [Sorting out the result type] in RdrHsSyn
 909
 910        ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
 911               (addErr (badRecResTy doc))
 912        ; return (details', ResTyGADT res_ty) }
 913
 914 rnConDeclDetails :: SDoc
 915                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
 916                  -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
 917 rnConDeclDetails doc (PrefixCon tys)
 918   = mapM (rnLHsType doc) tys    `thenM` \ new_tys  ->
 919     return (PrefixCon new_tys)
 920
 921 rnConDeclDetails doc (InfixCon ty1 ty2)
 922   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 923     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 924     return (InfixCon new_ty1 new_ty2)
 925
 926 rnConDeclDetails doc (RecCon fields)
 927   = do  { new_fields <- rnConDeclFields doc fields
 928                 -- No need to check for duplicate fields
 929                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 930         ; return (RecCon new_fields) }
 931
 932 -- Rename family declarations
 933 --
 934 -- * This function is parametrised by the routine handling the index
 935 --   variables.  On the toplevel, these are defining occurences, whereas they
 936 --   are usage occurences for associated types.
 937 --
 938 rnFamily :: TyClDecl RdrName
 939          -> ([LHsTyVarBndr RdrName] ->
 940              ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 941              RnM (TyClDecl Name, FreeVars))
 942          -> RnM (TyClDecl Name, FreeVars)
 943
 944 rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
 945                            tcdLName = tycon, tcdTyVars = tyvars})
 946         bindIdxVars =
 947       do { bindIdxVars tyvars $ \tyvars' -> do {
 948          ; tycon' <- lookupLocatedTopBndrRn tycon
 949          ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
 950                               tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
 951                     emptyFVs)
 952          } }
 953 rnFamily d _ = pprPanic "rnFamily" (ppr d)
 954
 955 -- Rename associated type declarations (in classes)
 956 --
 957 -- * This can be family declarations and (default) type instances
 958 --
 959 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 960 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 961   where
 962     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
 963     rn_at (tydecl@TySynonym {}) =
 964       do
 965         unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
 966         rnTyClDecl tydecl
 967     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 968
 969     lookupIdxVars tyvars cont =
 970       do { checkForDups tyvars;
 971          ; tyvars' <- mapM lookupIdxVar tyvars
 972          ; cont tyvars'
 973          }
 974     -- Type index variables must be class parameters, which are the only
 975     -- type variables in scope at this point.
 976     lookupIdxVar (L l tyvar) =
 977       do
 978         name' <- lookupOccRn (hsTyVarName tyvar)
 979         return $ L l (replaceTyVarName tyvar name')
 980
 981     -- Type variable may only occur once.
 982     --
 983     checkForDups [] = return ()
 984     checkForDups (L loc tv:ltvs) =
 985       do { setSrcSpan loc $
 986              when (hsTyVarName tv `ltvElem` ltvs) $
 987                addErr (repeatedTyVar tv)
 988          ; checkForDups ltvs
 989          }
 990
 991     _       `ltvElem` [] = False
 992     rdrName `ltvElem` (L _ tv:ltvs)
 993       | rdrName == hsTyVarName tv = True
 994       | otherwise                 = rdrName `ltvElem` ltvs
 995
 996 deprecRecSyntax :: ConDecl RdrName -> SDoc
 997 deprecRecSyntax decl
 998   = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
 999                  <+> ptext (sLit "uses deprecated syntax")
1000          , ptext (sLit "Instead, use the form")
1001          , nest 2 (ppr decl) ]   -- Pretty printer uses new form
1002
1003 badRecResTy :: SDoc -> SDoc
1004 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
1005
1006 noPatterns :: SDoc
1007 noPatterns = text "Default definition for an associated synonym cannot have"
1008              <+> text "type pattern"
1009
1010 repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
1011 repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
1012                    quotes (ppr tv)
1013
1014 -- This data decl will parse OK
1015 --      data T = a Int
1016 -- treating "a" as the constructor.
1017 -- It is really hard to make the parser spot this malformation.
1018 -- So the renamer has to check that the constructor is legal
1019 --
1020 -- We can get an operator as the constructor, even in the prefix form:
1021 --      data T = :% Int Int
1022 -- from interface files, which always print in prefix form
1023
1024 checkConName :: RdrName -> TcRn ()
1025 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
1026
1027 badDataCon :: RdrName -> SDoc
1028 badDataCon name
1029    = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
1030 \end{code}
1031
1032
1033 %*********************************************************
1034 %*                                                      *
1035 \subsection{Support code for type/data declarations}
1036 %*                                                      *
1037 %*********************************************************
1038
1039 Get the mapping from constructors to fields for this module.
1040 It's convenient to do this after the data type decls have been renamed
1041 \begin{code}
1042 extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
1043 extendRecordFieldEnv tycl_decls inst_decls
1044   = do  { tcg_env <- getGblEnv
1045         ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
1046         ; return (tcg_env { tcg_field_env = field_env' }) }
1047   where
1048     -- we want to lookup:
1049     --  (a) a datatype constructor
1050     --  (b) a record field
1051     -- knowing that they're from this module.
1052     -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
1053     -- which keeps only the local ones.
1054     lookup x = do { x' <- lookupLocatedTopBndrRn x
1055                     ; return $ unLoc x'}
1056
1057     all_data_cons :: [ConDecl RdrName]
1058     all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
1059                          , L _ con <- cons ]
1060     all_tycl_decls = at_tycl_decls ++ tycl_decls
1061     at_tycl_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
1062                       -- Do not forget associated types!
1063
1064     get_con (ConDecl { con_name = con, con_details = RecCon flds })
1065             (RecFields env fld_set)
1066         = do { con' <- lookup con
1067              ; flds' <- mapM lookup (map cd_fld_name flds)
1068              ; let env'    = extendNameEnv env con' flds'
1069                    fld_set' = addListToNameSet fld_set flds'
1070              ; return $ (RecFields env' fld_set') }
1071     get_con _ env = return env
1072 \end{code}
1073
1074 %*********************************************************
1075 %*                                                      *
1076 \subsection{Support code to rename types}
1077 %*                                                      *
1078 %*********************************************************
1079
1080 \begin{code}
1081 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
1082
1083 rnFds doc fds
1084   = mapM (wrapLocM rn_fds) fds
1085   where
1086     rn_fds (tys1, tys2)
1087       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
1088         rnHsTyVars doc tys2             `thenM` \ tys2' ->
1089         return (tys1', tys2')
1090
1091 rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
1092 rnHsTyVars doc tvs  = mapM (rnHsTyVar doc) tvs
1093
1094 rnHsTyVar :: SDoc -> RdrName -> RnM Name
1095 rnHsTyVar _doc tyvar = lookupOccRn tyvar
1096 \end{code}
1097
1098