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, 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     ASSERT( distinctTyVarBndrs tyvars )   -- Tyvars should be distinct
 658     do  { 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, tcdTyVars = tyvars,
 723                               tcdTyPats = typatsMaybe, tcdSynRhs = ty})
 724   = ASSERT( distinctTyVarBndrs tyvars )   -- Tyvars should be distinct
 725     do { 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 distinctTyVarBndrs :: [LHsTyVarBndr RdrName] -> Bool
 805 -- The tyvar binders should have distinct names
 806 distinctTyVarBndrs tvs
 807   = null (findDupsEq eq tvs)
 808   where
 809     eq (L _ v1) (L _ v2) = hsTyVarName v1 == hsTyVarName v2
 810
 811 badGadtStupidTheta :: Located RdrName -> SDoc
 812 badGadtStupidTheta _
 813   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
 814           ptext (sLit "(You can put a context on each contructor, though.)")]
 815 \end{code}
 816
 817
 818 %*********************************************************
 819 %*                                                      *
 820 \subsection{Support code for type/data declarations}
 821 %*                                                      *
 822 %*********************************************************
 823
 824 \begin{code}
 825 -- Although, we are processing type patterns here, all type variables will
 826 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 827 -- type declaration to which these patterns belong)
 828 --
 829 rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
 830 rnTyPats _   Nothing       = return Nothing
 831 rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
 832
 833 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 834 rnConDecls _tycon condecls
 835   = mapM (wrapLocM rnConDecl) condecls
 836
 837 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 838 rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
 839                         , con_cxt = cxt, con_details = details
 840                         , con_res = res_ty, con_doc = mb_doc
 841                         , con_old_rec = old_rec, con_explicit = expl })
 842   = do  { addLocM checkConName name
 843         ; when old_rec (addWarn (deprecRecSyntax decl))
 844
 845         ; new_name <- lookupLocatedTopBndrRn name
 846         ; name_env <- getLocalRdrEnv
 847
 848         -- For H98 syntax, the tvs are the existential ones
 849         -- For GADT syntax, the tvs are all the quantified tyvars
 850         -- Hence the 'filter' in the ResTyH98 case only
 851         ; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
 852               arg_tys       = hsConDeclArgTys details
 853               implicit_tvs  = case res_ty of
 854                                 ResTyH98     -> filter not_in_scope $
 855                                                 get_rdr_tvs arg_tys
 856                                 ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 857               new_tvs = case expl of
 858                           Explicit -> tvs
 859                           Implicit -> userHsTyVarBndrs implicit_tvs
 860
 861         ; mb_doc' <- rnMbLHsDoc mb_doc
 862
 863         ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
 864         { new_context <- rnContext doc cxt
 865         ; new_details <- rnConDeclDetails doc details
 866         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
 867         ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
 868                        , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
 869  where
 870     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 871     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 872
 873 rnConResult :: SDoc
 874             -> HsConDetails (LHsType Name) [ConDeclField Name]
 875             -> ResType RdrName
 876             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
 877                     ResType Name)
 878 rnConResult _ details ResTyH98 = return (details, ResTyH98)
 879 rnConResult doc details (ResTyGADT ty)
 880   = do { ty' <- rnLHsType doc ty
 881        ; let (arg_tys, res_ty) = splitHsFunType ty'
 882                 -- We can finally split it up,
 883                 -- now the renamer has dealt with fixities
 884                 -- See Note [Sorting out the result type] in RdrHsSyn
 885
 886              details' = case details of
 887                            RecCon {}    -> details
 888                            PrefixCon {} -> PrefixCon arg_tys
 889                            InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
 890                           -- See Note [Sorting out the result type] in RdrHsSyn
 891
 892        ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
 893               (addErr (badRecResTy doc))
 894        ; return (details', ResTyGADT res_ty) }
 895
 896 rnConDeclDetails :: SDoc
 897                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
 898                  -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
 899 rnConDeclDetails doc (PrefixCon tys)
 900   = mapM (rnLHsType doc) tys    `thenM` \ new_tys  ->
 901     return (PrefixCon new_tys)
 902
 903 rnConDeclDetails doc (InfixCon ty1 ty2)
 904   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 905     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 906     return (InfixCon new_ty1 new_ty2)
 907
 908 rnConDeclDetails doc (RecCon fields)
 909   = do  { new_fields <- rnConDeclFields doc fields
 910                 -- No need to check for duplicate fields
 911                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 912         ; return (RecCon new_fields) }
 913
 914 -- Rename family declarations
 915 --
 916 -- * This function is parametrised by the routine handling the index
 917 --   variables.  On the toplevel, these are defining occurences, whereas they
 918 --   are usage occurences for associated types.
 919 --
 920 rnFamily :: TyClDecl RdrName
 921          -> (SDoc -> [LHsTyVarBndr RdrName] ->
 922              ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 923              RnM (TyClDecl Name, FreeVars))
 924          -> RnM (TyClDecl Name, FreeVars)
 925
 926 rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
 927                            tcdLName = tycon, tcdTyVars = tyvars})
 928         bindIdxVars =
 929       do { checkM (isDataFlavour flavour                      -- for synonyms,
 930                    || not (null tyvars)) $ addErr needOneIdx  -- no. of indexes >= 1
 931          ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
 932          ; tycon' <- lookupLocatedTopBndrRn tycon
 933          ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
 934                               tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
 935                     emptyFVs)
 936          } }
 937       where
 938         isDataFlavour DataFamily = True
 939         isDataFlavour _          = False
 940 rnFamily d _ = pprPanic "rnFamily" (ppr d)
 941
 942 family_doc :: Located RdrName -> SDoc
 943 family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
 944
 945 needOneIdx :: SDoc
 946 needOneIdx = text "Type family declarations requires at least one type index"
 947
 948 -- Rename associated type declarations (in classes)
 949 --
 950 -- * This can be family declarations and (default) type instances
 951 --
 952 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 953 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 954   where
 955     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
 956     rn_at (tydecl@TySynonym {}) =
 957       do
 958         checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
 959         rnTyClDecl tydecl
 960     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 961
 962     lookupIdxVars _ tyvars cont =
 963       do { checkForDups tyvars;
 964          ; tyvars' <- mapM lookupIdxVar tyvars
 965          ; cont tyvars'
 966          }
 967     -- Type index variables must be class parameters, which are the only
 968     -- type variables in scope at this point.
 969     lookupIdxVar (L l tyvar) =
 970       do
 971         name' <- lookupOccRn (hsTyVarName tyvar)
 972         return $ L l (replaceTyVarName tyvar name')
 973
 974     -- Type variable may only occur once.
 975     --
 976     checkForDups [] = return ()
 977     checkForDups (L loc tv:ltvs) =
 978       do { setSrcSpan loc $
 979              when (hsTyVarName tv `ltvElem` ltvs) $
 980                addErr (repeatedTyVar tv)
 981          ; checkForDups ltvs
 982          }
 983
 984     _       `ltvElem` [] = False
 985     rdrName `ltvElem` (L _ tv:ltvs)
 986       | rdrName == hsTyVarName tv = True
 987       | otherwise                 = rdrName `ltvElem` ltvs
 988
 989 deprecRecSyntax :: ConDecl RdrName -> SDoc
 990 deprecRecSyntax decl
 991   = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
 992                  <+> ptext (sLit "uses deprecated syntax")
 993          , ptext (sLit "Instead, use the form")
 994          , nest 2 (ppr decl) ]   -- Pretty printer uses new form
 995
 996 badRecResTy :: SDoc -> SDoc
 997 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
 998
 999 noPatterns :: SDoc
1000 noPatterns = text "Default definition for an associated synonym cannot have"
1001              <+> text "type pattern"
1002
1003 repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
1004 repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
1005                    quotes (ppr tv)
1006
1007 -- This data decl will parse OK
1008 --      data T = a Int
1009 -- treating "a" as the constructor.
1010 -- It is really hard to make the parser spot this malformation.
1011 -- So the renamer has to check that the constructor is legal
1012 --
1013 -- We can get an operator as the constructor, even in the prefix form:
1014 --      data T = :% Int Int
1015 -- from interface files, which always print in prefix form
1016
1017 checkConName :: RdrName -> TcRn ()
1018 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
1019
1020 badDataCon :: RdrName -> SDoc
1021 badDataCon name
1022    = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
1023 \end{code}
1024
1025
1026 %*********************************************************
1027 %*                                                      *
1028 \subsection{Support code for type/data declarations}
1029 %*                                                      *
1030 %*********************************************************
1031
1032 Get the mapping from constructors to fields for this module.
1033 It's convenient to do this after the data type decls have been renamed
1034 \begin{code}
1035 extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
1036 extendRecordFieldEnv tycl_decls inst_decls
1037   = do  { tcg_env <- getGblEnv
1038         ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
1039         ; return (tcg_env { tcg_field_env = field_env' }) }
1040   where
1041     -- we want to lookup:
1042     --  (a) a datatype constructor
1043     --  (b) a record field
1044     -- knowing that they're from this module.
1045     -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
1046     -- which keeps only the local ones.
1047     lookup x = do { x' <- lookupLocatedTopBndrRn x
1048                     ; return $ unLoc x'}
1049
1050     all_data_cons :: [ConDecl RdrName]
1051     all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
1052                          , L _ con <- cons ]
1053     all_tycl_decls = at_tycl_decls ++ tycl_decls
1054     at_tycl_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
1055                       -- Do not forget associated types!
1056
1057     get_con (ConDecl { con_name = con, con_details = RecCon flds })
1058             (RecFields env fld_set)
1059         = do { con' <- lookup con
1060              ; flds' <- mapM lookup (map cd_fld_name flds)
1061              ; let env'    = extendNameEnv env con' flds'
1062                    fld_set' = addListToNameSet fld_set flds'
1063              ; return $ (RecFields env' fld_set') }
1064     get_con _ env = return env
1065 \end{code}
1066
1067 %*********************************************************
1068 %*                                                      *
1069 \subsection{Support code to rename types}
1070 %*                                                      *
1071 %*********************************************************
1072
1073 \begin{code}
1074 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
1075
1076 rnFds doc fds
1077   = mapM (wrapLocM rn_fds) fds
1078   where
1079     rn_fds (tys1, tys2)
1080       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
1081         rnHsTyVars doc tys2             `thenM` \ tys2' ->
1082         return (tys1', tys2')
1083
1084 rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
1085 rnHsTyVars doc tvs  = mapM (rnHsTyVar doc) tvs
1086
1087 rnHsTyVar :: SDoc -> RdrName -> RnM Name
1088 rnHsTyVar _doc tyvar = lookupOccRn tyvar
1089 \end{code}
1090
1091