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 import Digraph          ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
  54
  55 import Control.Monad
  56 import Maybes( orElse )
  57 import Data.Maybe
  58 \end{code}
  59
  60 \begin{code}
  61 -- XXX
  62 thenM :: Monad a => a b -> (b -> a c) -> a c
  63 thenM = (>>=)
  64
  65 thenM_ :: Monad a => a b -> a c -> a c
  66 thenM_ = (>>)
  67 \end{code}
  68
  69 @rnSourceDecl@ `renames' declarations.
  70 It simultaneously performs dependency analysis and precedence parsing.
  71 It also does the following error checks:
  72 \begin{enumerate}
  73 \item
  74 Checks that tyvars are used properly. This includes checking
  75 for undefined tyvars, and tyvars in contexts that are ambiguous.
  76 (Some of this checking has now been moved to module @TcMonoType@,
  77 since we don't have functional dependency information at this point.)
  78 \item
  79 Checks that all variable occurences are defined.
  80 \item
  81 Checks the @(..)@ etc constraints in the export list.
  82 \end{enumerate}
  83
  84
  85 \begin{code}
  86 -- Brings the binders of the group into scope in the appropriate places;
  87 -- does NOT assume that anything is in scope already
  88 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
  89 -- Rename a HsGroup; used for normal source files *and* hs-boot files
  90 rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
  91                             hs_tyclds  = tycl_decls,
  92                             hs_instds  = inst_decls,
  93                             hs_derivds = deriv_decls,
  94                             hs_fixds   = fix_decls,
  95                             hs_warnds  = warn_decls,
  96                             hs_annds   = ann_decls,
  97                             hs_fords   = foreign_decls,
  98                             hs_defds   = default_decls,
  99                             hs_ruleds  = rule_decls,
 100                             hs_docs    = docs })
 101  = do {
 102    -- (A) Process the fixity declarations, creating a mapping from
 103    --     FastStrings to FixItems.
 104    --     Also checks for duplcates.
 105    local_fix_env <- makeMiniFixityEnv fix_decls;
 106
 107    -- (B) Bring top level binders (and their fixities) into scope,
 108    --     *except* for the value bindings, which get brought in below.
 109    --     However *do* include class ops, data constructors
 110    --     And for hs-boot files *do* include the value signatures
 111    tc_avails <- getLocalNonValBinders group ;
 112    tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ;
 113    setEnvs tc_envs $ do {
 114
 115    failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
 116
 117    -- (C) Extract the mapping from data constructors to field names and
 118    --     extend the record field env.
 119    --     This depends on the data constructors and field names being in
 120    --     scope from (B) above
 121    inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
 122
 123    -- (D) Rename the left-hand sides of the value bindings.
 124    --     This depends on everything from (B) being in scope,
 125    --     and on (C) for resolving record wild cards.
 126    --     It uses the fixity env from (A) to bind fixities for view patterns.
 127    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
 128    -- bind the LHSes (and their fixities) in the global rdr environment
 129    let { val_binders = collectHsValBinders new_lhs ;
 130          val_bndr_set = mkNameSet val_binders ;
 131          all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
 132          val_avails = map Avail val_binders
 133        } ;
 134    (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
 135    setEnvs (tcg_env, tcl_env) $ do {
 136
 137    --  Now everything is in scope, as the remaining renaming assumes.
 138
 139    -- (E) Rename type and class decls
 140    --     (note that value LHSes need to be in scope for default methods)
 141    --
 142    -- You might think that we could build proper def/use information
 143    -- for type and class declarations, but they can be involved
 144    -- in mutual recursion across modules, and we only do the SCC
 145    -- analysis for them in the type checker.
 146    -- So we content ourselves with gathering uses only; that
 147    -- means we'll only report a declaration as unused if it isn't
 148    -- mentioned at all.  Ah well.
 149    traceRn (text "Start rnTyClDecls") ;
 150    (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
 151
 152    -- (F) Rename Value declarations right-hand sides
 153    traceRn (text "Start rnmono") ;
 154    (rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ;
 155    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
 156
 157    -- (G) Rename Fixity and deprecations
 158
 159    -- Rename fixity declarations and error if we try to
 160    -- fix something from another module (duplicates were checked in (A))
 161    rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
 162
 163    -- Rename deprec decls;
 164    -- check for duplicates and ensure that deprecated things are defined locally
 165    -- at the moment, we don't keep these around past renaming
 166    rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
 167
 168    -- (H) Rename Everything else
 169
 170    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
 171    (rn_rule_decls,    src_fvs3) <- setOptM Opt_ScopedTypeVariables $
 172                                    rnList rnHsRuleDecl    rule_decls ;
 173                            -- Inside RULES, scoped type variables are on
 174    (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
 175    (rn_ann_decls,     src_fvs5) <- rnList rnAnnDecl       ann_decls ;
 176    (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl   default_decls ;
 177    (rn_deriv_decls,   src_fvs7) <- rnList rnSrcDerivDecl  deriv_decls ;
 178       -- Haddock docs; no free vars
 179    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 180
 181    -- (I) Compute the results and return
 182    let {rn_group = HsGroup { hs_valds   = rn_val_decls,
 183                              hs_tyclds  = rn_tycl_decls,
 184                              hs_instds  = rn_inst_decls,
 185                              hs_derivds = rn_deriv_decls,
 186                              hs_fixds   = rn_fix_decls,
 187                              hs_warnds  = [], -- warns are returned in the tcg_env
 188                                              -- (see below) not in the HsGroup
 189                              hs_fords  = rn_foreign_decls,
 190                              hs_annds  = rn_ann_decls,
 191                              hs_defds  = rn_default_decls,
 192                              hs_ruleds = rn_rule_decls,
 193                              hs_docs   = rn_docs } ;
 194
 195         tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
 196         ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
 197         other_def  = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
 198         other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
 199                               src_fvs5, src_fvs6, src_fvs7] ;
 200                 -- It is tiresome to gather the binders from type and class decls
 201
 202         src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
 203                 -- Instance decls may have occurrences of things bound in bind_dus
 204                 -- so we must put other_fvs last
 205
 206         final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
 207                         in -- we return the deprecs in the env, not in the HsGroup above
 208                         tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
 209        } ;
 210
 211    traceRn (text "finish rnSrc" <+> ppr rn_group) ;
 212    traceRn (text "finish Dus" <+> ppr src_dus ) ;
 213    return (final_tcg_env, rn_group)
 214                     }}}}
 215
 216 -- some utils because we do this a bunch above
 217 -- compute and install the new env
 218 inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
 219 inNewEnv env cont = do e <- env
 220                        setGblEnv e $ cont e
 221
 222 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
 223 -- This function could be defined lower down in the module hierarchy,
 224 -- but there doesn't seem anywhere very logical to put it.
 225 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
 226
 227 rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
 228 rnList f xs = mapFvRn (wrapLocFstM f) xs
 229 \end{code}
 230
 231
 232 %*********************************************************
 233 %*                                                       *
 234         HsDoc stuff
 235 %*                                                       *
 236 %*********************************************************
 237
 238 \begin{code}
 239 rnDocDecl :: DocDecl -> RnM DocDecl
 240 rnDocDecl (DocCommentNext doc) = do
 241   rn_doc <- rnHsDoc doc
 242   return (DocCommentNext rn_doc)
 243 rnDocDecl (DocCommentPrev doc) = do
 244   rn_doc <- rnHsDoc doc
 245   return (DocCommentPrev rn_doc)
 246 rnDocDecl (DocCommentNamed str doc) = do
 247   rn_doc <- rnHsDoc doc
 248   return (DocCommentNamed str rn_doc)
 249 rnDocDecl (DocGroup lev doc) = do
 250   rn_doc <- rnHsDoc doc
 251   return (DocGroup lev rn_doc)
 252 \end{code}
 253
 254
 255 %*********************************************************
 256 %*                                                       *
 257         Source-code fixity declarations
 258 %*                                                       *
 259 %*********************************************************
 260
 261 \begin{code}
 262 rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
 263 -- Rename the fixity decls, so we can put
 264 -- the renamed decls in the renamed syntax tree
 265 -- Errors if the thing being fixed is not defined locally.
 266 --
 267 -- The returned FixitySigs are not actually used for anything,
 268 -- except perhaps the GHCi API
 269 rnSrcFixityDecls bound_names fix_decls
 270   = do fix_decls <- mapM rn_decl fix_decls
 271        return (concat fix_decls)
 272   where
 273     rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
 274         -- GHC extension: look up both the tycon and data con
 275         -- for con-like things; hence returning a list
 276         -- If neither are in scope, report an error; otherwise
 277         -- return a fixity sig for each (slightly odd)
 278     rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
 279       = setSrcSpan name_loc $
 280                     -- this lookup will fail if the definition isn't local
 281         do names <- lookupLocalDataTcNames bound_names what rdr_name
 282            return [ L loc (FixitySig (L name_loc name) fixity)
 283                   | name <- names ]
 284     what = ptext (sLit "fixity signature")
 285 \end{code}
 286
 287
 288 %*********************************************************
 289 %*                                                       *
 290         Source-code deprecations declarations
 291 %*                                                       *
 292 %*********************************************************
 293
 294 Check that the deprecated names are defined, are defined locally, and
 295 that there are no duplicate deprecations.
 296
 297 It's only imported deprecations, dealt with in RnIfaces, that we
 298 gather them together.
 299
 300 \begin{code}
 301 -- checks that the deprecations are defined locally, and that there are no duplicates
 302 rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
 303 rnSrcWarnDecls _bound_names []
 304   = return NoWarnings
 305
 306 rnSrcWarnDecls bound_names decls
 307   = do { -- check for duplicates
 308        ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
 309                           in 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 . hsTyClDeclBinders) 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 <- xoptM 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 <- xoptM 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 rnTyClDecls :: [[LTyClDecl RdrName]] -> RnM ([[LTyClDecl Name]], FreeVars)
 681 -- Renamed the declarations and do depedency analysis on them
 682 rnTyClDecls tycl_ds
 683   = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds)
 684
 685        ; let sccs :: [SCC (LTyClDecl Name)]
 686              sccs = depAnalTyClDecls ds_w_fvs
 687
 688              all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs
 689
 690        ; return (map flattenSCC sccs, all_fvs) }
 691
 692 rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
 693 rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
 694   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 695     return (ForeignType {tcdLName = name', tcdExtName = ext_name},
 696              emptyFVs)
 697
 698 -- all flavours of type family declarations ("type family", "newtype fanily",
 699 -- and "data family")
 700 rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV
 701
 702 -- "data", "newtype", "data instance, and "newtype instance" declarations
 703 rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 704                            tcdLName = tycon, tcdTyVars = tyvars,
 705                            tcdTyPats = typats, tcdCons = condecls,
 706                            tcdKindSig = sig, tcdDerivs = derivs}
 707   = do  { tycon' <- if isFamInstDecl tydecl
 708                     then lookupLocatedOccRn     tycon -- may be imported family
 709                     else lookupLocatedTopBndrRn tycon
 710         ; checkTc (h98_style || null (unLoc context))
 711                   (badGadtStupidTheta tycon)
 712         ; ((tyvars', context', typats', derivs'), stuff_fvs)
 713                 <- bindTyVarsFV tyvars $ \ tyvars' -> do
 714                                  -- Checks for distinct tyvars
 715                    { context' <- rnContext data_doc context
 716                    ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
 717                    ; (derivs', fvs2) <- rn_derivs derivs
 718                    ; let fvs = fvs1 `plusFV` fvs2 `plusFV`
 719                                extractHsCtxtTyNames context'
 720                    ; return ((tyvars', context', typats', derivs'), fvs) }
 721
 722         -- For the constructor declarations, bring into scope the tyvars
 723         -- bound by the header, but *only* in the H98 case
 724         -- Reason: for GADTs, the type variables in the declaration
 725         --   do not scope over the constructor signatures
 726         --   data T a where { T1 :: forall b. b-> b }
 727         ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
 728                               | otherwise = []
 729         ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
 730                                   rnConDecls condecls
 731                 -- No need to check for duplicate constructor decls
 732                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 733
 734         ; return (TyData {tcdND = new_or_data, tcdCtxt = context',
 735                            tcdLName = tycon', tcdTyVars = tyvars',
 736                            tcdTyPats = typats', tcdKindSig = sig,
 737                            tcdCons = condecls', tcdDerivs = derivs'},
 738                    con_fvs `plusFV` stuff_fvs)
 739         }
 740   where
 741     h98_style = case condecls of         -- Note [Stupid theta]
 742                      L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
 743                      _                                             -> True
 744
 745     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 746
 747     rn_derivs Nothing   = return (Nothing, emptyFVs)
 748     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 749                           return (Just ds', extractHsTyNames_s ds')
 750
 751 -- "type" and "type instance" declarations
 752 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
 753                               tcdTyPats = typats, tcdSynRhs = ty})
 754   = bindTyVarsFV tyvars $ \ tyvars' -> do
 755     {            -- Checks for distinct tyvars
 756       name' <- if isFamInstDecl tydecl
 757                   then lookupLocatedOccRn     name -- may be imported family
 758                   else lookupLocatedTopBndrRn name
 759     ; (typats',fvs1) <- rnTyPats syn_doc name' typats
 760     ; (ty', fvs2)    <- rnHsTypeFVs syn_doc ty
 761     ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
 762                         , tcdTyPats = typats', tcdSynRhs = ty'},
 763               fvs1 `plusFV` fvs2) }
 764   where
 765     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 766
 767 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 768                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 769                        tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
 770   = do  { cname' <- lookupLocatedTopBndrRn cname
 771
 772         -- Tyvars scope over superclass context and method signatures
 773         ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
 774             <- bindTyVarsFV tyvars $ \ tyvars' -> do
 775                  -- Checks for distinct tyvars
 776              { context' <- rnContext cls_doc context
 777              ; fds' <- rnFds cls_doc fds
 778              ; (ats', at_fvs) <- rnATs ats
 779              ; sigs' <- renameSigs Nothing okClsDclSig sigs
 780              ; let fvs = at_fvs `plusFV`
 781                          extractHsCtxtTyNames context'  `plusFV`
 782                          hsSigsFVs sigs'
 783                          -- The fundeps have no free variables
 784              ; return ((tyvars', context', fds', ats', sigs'), fvs) }
 785
 786         -- No need to check for duplicate associated type decls
 787         -- since that is done by RnNames.extendGlobalRdrEnvRn
 788
 789         -- Check the signatures
 790         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 791         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
 792         ; checkDupRdrNames sig_rdr_names_w_locs
 793                 -- Typechecker is responsible for checking that we only
 794                 -- give default-method bindings for things in this class.
 795                 -- The renamer *could* check this for class decls, but can't
 796                 -- for instance decls.
 797
 798         -- The newLocals call is tiresome: given a generic class decl
 799         --      class C a where
 800         --        op :: a -> a
 801         --        op {| x+y |} (Inl a) = ...
 802         --        op {| x+y |} (Inr b) = ...
 803         --        op {| a*b |} (a*b)   = ...
 804         -- we want to name both "x" tyvars with the same unique, so that they are
 805         -- easy to group together in the typechecker.
 806         ; (mbinds', meth_fvs)
 807             <- extendTyVarEnvForMethodBinds tyvars' $ do
 808             { name_env <- getLocalRdrEnv
 809             ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
 810                                                  not (unLoc tv `elemLocalRdrEnv` name_env) ]
 811                 -- No need to check for duplicate method signatures
 812                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 813                 -- and the methods are already in scope
 814             ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
 815             ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
 816
 817   -- Haddock docs
 818         ; docs' <- mapM (wrapLocM rnDocDecl) docs
 819
 820         ; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
 821                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
 822                               tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
 823                   meth_fvs `plusFV` stuff_fvs) }
 824   where
 825     cls_doc  = text "In the declaration for class"      <+> ppr cname
 826
 827 badGadtStupidTheta :: Located RdrName -> SDoc
 828 badGadtStupidTheta _
 829   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
 830           ptext (sLit "(You can put a context on each contructor, though.)")]
 831 \end{code}
 832
 833 Note [Stupid theta]
 834 ~~~~~~~~~~~~~~~~~~~
 835 Trac #3850 complains about a regression wrt 6.10 for
 836      data Show a => T a
 837 There is no reason not to allow the stupid theta if there are no data
 838 constructors.  It's still stupid, but does no harm, and I don't want
 839 to cause programs to break unnecessarily (notably HList).  So if there
 840 are no data constructors we allow h98_style = True
 841
 842
 843 \begin{code}
 844 depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
 845 -- See Note [Dependency analysis of type and class decls]
 846 depAnalTyClDecls ds_w_fvs
 847   = stronglyConnCompFromEdgedVertices edges
 848   where
 849     edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs))
 850             | (d, fvs) <- ds_w_fvs ]
 851     get_assoc n = lookupNameEnv assoc_env n `orElse` n
 852     assoc_env = mkNameEnv [ (tcdName assoc_decl, cls_name)
 853                           | (L _ (ClassDecl { tcdLName = L _ cls_name
 854                                             , tcdATs   = ats }) ,_) <- ds_w_fvs
 855                           , L _ assoc_decl <- ats ]
 856 \end{code}
 857
 858 Note [Dependency analysis of type and class decls]
 859 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 860 We need to do dependency analysis on type and class declarations
 861 else we get bad error messages.  Consider
 862
 863      data T f a = MkT f a
 864      data S f a = MkS f (T f a)
 865
 866 This has a kind error, but the error message is better if you
 867 check T first, (fixing its kind) and *then* S.  If you do kind
 868 inference together, you might get an error reported in S, which
 869 is jolly confusing.  See Trac #4875
 870
 871
 872 %*********************************************************
 873 %*                                                      *
 874 \subsection{Support code for type/data declarations}
 875 %*                                                      *
 876 %*********************************************************
 877
 878 \begin{code}
 879 rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
 880 -- Although, we are processing type patterns here, all type variables will
 881 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 882 -- type declaration to which these patterns belong)
 883 rnTyPats _   _  Nothing
 884   = return (Nothing, emptyFVs)
 885 rnTyPats doc tc (Just typats)
 886   = do { typats' <- rnLHsTypes doc typats
 887        ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc)
 888              -- type instance => use, hence addOneFV
 889        ; return (Just typats', fvs) }
 890
 891 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
 892 rnConDecls condecls
 893   = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
 894        ; return (condecls', plusFVs (map conDeclFVs condecls')) }
 895
 896 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 897 rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
 898                                , con_cxt = cxt, con_details = details
 899                                , con_res = res_ty, con_doc = mb_doc
 900                                , con_old_rec = old_rec, con_explicit = expl })
 901   = do  { addLocM checkConName name
 902         ; when old_rec (addWarn (deprecRecSyntax decl))
 903         ; new_name <- lookupLocatedTopBndrRn name
 904
 905            -- For H98 syntax, the tvs are the existential ones
 906            -- For GADT syntax, the tvs are all the quantified tyvars
 907            -- Hence the 'filter' in the ResTyH98 case only
 908         ; rdr_env <- getLocalRdrEnv
 909         ; let in_scope     = (`elemLocalRdrEnv` rdr_env) . unLoc
 910               arg_tys      = hsConDeclArgTys details
 911               implicit_tvs = case res_ty of
 912                                ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
 913                                ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 914               new_tvs = case expl of
 915                           Explicit -> tvs
 916                           Implicit -> userHsTyVarBndrs implicit_tvs
 917
 918         ; mb_doc' <- rnMbLHsDoc mb_doc
 919
 920         ; bindTyVarsRn new_tvs $ \new_tyvars -> do
 921         { new_context <- rnContext doc cxt
 922         ; new_details <- rnConDeclDetails doc details
 923         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
 924         ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
 925                        , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
 926  where
 927     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 928     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 929
 930 rnConResult :: SDoc
 931             -> HsConDetails (LHsType Name) [ConDeclField Name]
 932             -> ResType RdrName
 933             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
 934                     ResType Name)
 935 rnConResult _ details ResTyH98 = return (details, ResTyH98)
 936 rnConResult doc details (ResTyGADT ty)
 937   = do { ty' <- rnLHsType doc ty
 938        ; let (arg_tys, res_ty) = splitHsFunType ty'
 939                 -- We can finally split it up,
 940                 -- now the renamer has dealt with fixities
 941                 -- See Note [Sorting out the result type] in RdrHsSyn
 942
 943              details' = case details of
 944                            RecCon {}    -> details
 945                            PrefixCon {} -> PrefixCon arg_tys
 946                            InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
 947                           -- See Note [Sorting out the result type] in RdrHsSyn
 948
 949        ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
 950               (addErr (badRecResTy doc))
 951        ; return (details', ResTyGADT res_ty) }
 952
 953 rnConDeclDetails :: SDoc
 954                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
 955                  -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
 956 rnConDeclDetails doc (PrefixCon tys)
 957   = mapM (rnLHsType doc) tys    `thenM` \ new_tys  ->
 958     return (PrefixCon new_tys)
 959
 960 rnConDeclDetails doc (InfixCon ty1 ty2)
 961   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 962     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 963     return (InfixCon new_ty1 new_ty2)
 964
 965 rnConDeclDetails doc (RecCon fields)
 966   = do  { new_fields <- rnConDeclFields doc fields
 967                 -- No need to check for duplicate fields
 968                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 969         ; return (RecCon new_fields) }
 970
 971 -- Rename family declarations
 972 --
 973 -- * This function is parametrised by the routine handling the index
 974 --   variables.  On the toplevel, these are defining occurences, whereas they
 975 --   are usage occurences for associated types.
 976 --
 977 rnFamily :: TyClDecl RdrName
 978          -> ([LHsTyVarBndr RdrName] ->
 979              ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 980              RnM (TyClDecl Name, FreeVars))
 981          -> RnM (TyClDecl Name, FreeVars)
 982
 983 rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
 984                            tcdLName = tycon, tcdTyVars = tyvars})
 985         bindIdxVars =
 986       do { bindIdxVars tyvars $ \tyvars' -> do {
 987          ; tycon' <- lookupLocatedTopBndrRn tycon
 988          ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
 989                               tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
 990                     emptyFVs)
 991          } }
 992 rnFamily d _ = pprPanic "rnFamily" (ppr d)
 993
 994 -- Rename associated type declarations (in classes)
 995 --
 996 -- * This can be family declarations and (default) type instances
 997 --
 998 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 999 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
1000   where
1001     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
1002     rn_at (tydecl@TySynonym {}) =
1003       do
1004         unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
1005         rnTyClDecl tydecl
1006     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
1007
1008     lookupIdxVars tyvars cont =
1009       do { checkForDups tyvars
1010          ; tyvars' <- mapM lookupIdxVar tyvars
1011          ; cont tyvars'
1012          }
1013     -- Type index variables must be class parameters, which are the only
1014     -- type variables in scope at this point.
1015     lookupIdxVar (L l tyvar) =
1016       do
1017         name' <- lookupOccRn (hsTyVarName tyvar)
1018         return $ L l (replaceTyVarName tyvar name')
1019
1020     -- Type variable may only occur once.
1021     --
1022     checkForDups [] = return ()
1023     checkForDups (L loc tv:ltvs) =
1024       do { setSrcSpan loc $
1025              when (hsTyVarName tv `ltvElem` ltvs) $
1026                addErr (repeatedTyVar tv)
1027          ; checkForDups ltvs
1028          }
1029
1030     _       `ltvElem` [] = False
1031     rdrName `ltvElem` (L _ tv:ltvs)
1032       | rdrName == hsTyVarName tv = True
1033       | otherwise                 = rdrName `ltvElem` ltvs
1034
1035 deprecRecSyntax :: ConDecl RdrName -> SDoc
1036 deprecRecSyntax decl
1037   = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
1038                  <+> ptext (sLit "uses deprecated syntax")
1039          , ptext (sLit "Instead, use the form")
1040          , nest 2 (ppr decl) ]   -- Pretty printer uses new form
1041
1042 badRecResTy :: SDoc -> SDoc
1043 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
1044
1045 noPatterns :: SDoc
1046 noPatterns = text "Default definition for an associated synonym cannot have"
1047              <+> text "type pattern"
1048
1049 repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
1050 repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
1051                    quotes (ppr tv)
1052
1053 -- This data decl will parse OK
1054 --      data T = a Int
1055 -- treating "a" as the constructor.
1056 -- It is really hard to make the parser spot this malformation.
1057 -- So the renamer has to check that the constructor is legal
1058 --
1059 -- We can get an operator as the constructor, even in the prefix form:
1060 --      data T = :% Int Int
1061 -- from interface files, which always print in prefix form
1062
1063 checkConName :: RdrName -> TcRn ()
1064 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
1065
1066 badDataCon :: RdrName -> SDoc
1067 badDataCon name
1068    = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
1069 \end{code}
1070
1071
1072 %*********************************************************
1073 %*                                                      *
1074 \subsection{Support code for type/data declarations}
1075 %*                                                      *
1076 %*********************************************************
1077
1078 Get the mapping from constructors to fields for this module.
1079 It's convenient to do this after the data type decls have been renamed
1080 \begin{code}
1081 extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv
1082 extendRecordFieldEnv tycl_decls inst_decls
1083   = do  { tcg_env <- getGblEnv
1084         ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
1085         ; return (tcg_env { tcg_field_env = field_env' }) }
1086   where
1087     -- we want to lookup:
1088     --  (a) a datatype constructor
1089     --  (b) a record field
1090     -- knowing that they're from this module.
1091     -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
1092     -- which keeps only the local ones.
1093     lookup x = do { x' <- lookupLocatedTopBndrRn x
1094                     ; return $ unLoc x'}
1095
1096     all_data_cons :: [ConDecl RdrName]
1097     all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
1098                          , L _ con <- cons ]
1099     all_tycl_decls = at_tycl_decls ++ concat tycl_decls
1100     at_tycl_decls = instDeclATs inst_decls  -- Do not forget associated types!
1101
1102     get_con (ConDecl { con_name = con, con_details = RecCon flds })
1103             (RecFields env fld_set)
1104         = do { con' <- lookup con
1105              ; flds' <- mapM lookup (map cd_fld_name flds)
1106              ; let env'    = extendNameEnv env con' flds'
1107                    fld_set' = addListToNameSet fld_set flds'
1108              ; return $ (RecFields env' fld_set') }
1109     get_con _ env = return env
1110 \end{code}
1111
1112 %*********************************************************
1113 %*                                                      *
1114 \subsection{Support code to rename types}
1115 %*                                                      *
1116 %*********************************************************
1117
1118 \begin{code}
1119 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
1120
1121 rnFds doc fds
1122   = mapM (wrapLocM rn_fds) fds
1123   where
1124     rn_fds (tys1, tys2)
1125       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
1126         rnHsTyVars doc tys2             `thenM` \ tys2' ->
1127         return (tys1', tys2')
1128
1129 rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
1130 rnHsTyVars doc tvs  = mapM (rnHsTyVar doc) tvs
1131
1132 rnHsTyVar :: SDoc -> RdrName -> RnM Name
1133 rnHsTyVar _doc tyvar = lookupOccRn tyvar
1134 \end{code}
1135
1136
1137 %*********************************************************
1138 %*                                                      *
1139         findSplice
1140 %*                                                      *
1141 %*********************************************************
1142
1143 This code marches down the declarations, looking for the first
1144 Template Haskell splice.  As it does so it
1145         a) groups the declarations into a HsGroup
1146         b) runs any top-level quasi-quotes
1147
1148 \begin{code}
1149 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1150 findSplice ds = addl emptyRdrGroup ds
1151
1152 addl :: HsGroup RdrName -> [LHsDecl RdrName]
1153      -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1154 -- This stuff reverses the declarations (again) but it doesn't matter
1155 addl gp []           = return (gp, Nothing)
1156 addl gp (L l d : ds) = add gp l d ds
1157
1158
1159 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
1160     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1161
1162 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
1163   = do { -- We've found a top-level splice.  If it is an *implicit* one
1164          -- (i.e. a naked top level expression)
1165          case flag of
1166            Explicit -> return ()
1167            Implicit -> do { th_on <- xoptM Opt_TemplateHaskell
1168                           ; unless th_on $ setSrcSpan loc $
1169                             failWith badImplicitSplice }
1170
1171        ; return (gp, Just (splice, ds)) }
1172   where
1173     badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
1174
1175 #ifndef GHCI
1176 add _ _ (QuasiQuoteD qq) _
1177   = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq)
1178 #else
1179 add gp _ (QuasiQuoteD qq) ds            -- Expand quasiquotes
1180   = do { ds' <- runQuasiQuoteDecl qq
1181        ; addl gp (ds' ++ ds) }
1182 #endif
1183
1184 -- Class declarations: pull out the fixity signatures to the top
1185 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
1186   | isClassDecl d
1187   = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
1188     addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
1189   | otherwise
1190   = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
1191
1192 -- Signatures: fixity sigs go a different place than all others
1193 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
1194   = addl (gp {hs_fixds = L l f : ts}) ds
1195 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
1196   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
1197
1198 -- Value declarations: use add_bind
1199 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
1200   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
1201
1202 -- The rest are routine
1203 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
1204   = addl (gp { hs_instds = L l d : ts }) ds
1205 add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
1206   = addl (gp { hs_derivds = L l d : ts }) ds
1207 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
1208   = addl (gp { hs_defds = L l d : ts }) ds
1209 add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
1210   = addl (gp { hs_fords = L l d : ts }) ds
1211 add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
1212   = addl (gp { hs_warnds = L l d : ts }) ds
1213 add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
1214   = addl (gp { hs_annds = L l d : ts }) ds
1215 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
1216   = addl (gp { hs_ruleds = L l d : ts }) ds
1217 add gp l (DocD d) ds
1218   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
1219
1220 add_tycld :: LTyClDecl a -> [[LTyClDecl a]] -> [[LTyClDecl a]]
1221 add_tycld d []       = [[d]]
1222 add_tycld d (ds:dss) = (d:ds) : dss
1223
1224 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
1225 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
1226 add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
1227
1228 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
1229 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
1230 add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
1231 \end{code}