compiler/rename/RnSource.lhs

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