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