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