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