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         ( extractHsRhoRdrTyVars )
  21 import RnHsSyn
  22 import RnTypes
  23 import RnBinds          ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
  24                                 makeMiniFixityEnv)
  25 import RnEnv            ( lookupLocalDataTcNames, lookupLocatedOccRn,
  26                           lookupTopBndrRn, lookupLocatedTopBndrRn,
  27                           lookupOccRn, bindLocalNamesFV,
  28                           bindLocatedLocalsFV, bindPatSigTyVarsFV,
  29                           bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
  30                           bindLocalNames, checkDupRdrNames, mapFvRn
  31                         )
  32 import RnNames          ( getLocalNonValBinders, extendGlobalRdrEnvRn )
  33 import HscTypes         ( AvailInfo(..), 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_vects   = vect_decls,
 101                             hs_docs    = docs })
 102  = do {
 103    -- (A) Process the fixity declarations, creating a mapping from
 104    --     FastStrings to FixItems.
 105    --     Also checks for duplcates.
 106    local_fix_env <- makeMiniFixityEnv fix_decls;
 107
 108    -- (B) Bring top level binders (and their fixities) into scope,
 109    --     *except* for the value bindings, which get brought in below.
 110    --     However *do* include class ops, data constructors
 111    --     And for hs-boot files *do* include the value signatures
 112    tc_avails <- getLocalNonValBinders group ;
 113    tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ;
 114    setEnvs tc_envs $ do {
 115
 116    failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
 117
 118    -- (C) Extract the mapping from data constructors to field names and
 119    --     extend the record field env.
 120    --     This depends on the data constructors and field names being in
 121    --     scope from (B) above
 122    inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
 123
 124    -- (D) Rename the left-hand sides of the value bindings.
 125    --     This depends on everything from (B) being in scope,
 126    --     and on (C) for resolving record wild cards.
 127    --     It uses the fixity env from (A) to bind fixities for view patterns.
 128    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
 129    -- bind the LHSes (and their fixities) in the global rdr environment
 130    let { val_binders = collectHsValBinders new_lhs ;
 131          val_bndr_set = mkNameSet val_binders ;
 132          all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
 133          val_avails = map Avail val_binders
 134        } ;
 135    (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
 136    traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ;
 137    setEnvs (tcg_env, tcl_env) $ do {
 138
 139    --  Now everything is in scope, as the remaining renaming assumes.
 140
 141    -- (E) Rename type and class decls
 142    --     (note that value LHSes need to be in scope for default methods)
 143    --
 144    -- You might think that we could build proper def/use information
 145    -- for type and class declarations, but they can be involved
 146    -- in mutual recursion across modules, and we only do the SCC
 147    -- analysis for them in the type checker.
 148    -- So we content ourselves with gathering uses only; that
 149    -- means we'll only report a declaration as unused if it isn't
 150    -- mentioned at all.  Ah well.
 151    traceRn (text "Start rnTyClDecls") ;
 152    (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
 153
 154    -- (F) Rename Value declarations right-hand sides
 155    traceRn (text "Start rnmono") ;
 156    (rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ;
 157    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
 158
 159    -- (G) Rename Fixity and deprecations
 160
 161    -- Rename fixity declarations and error if we try to
 162    -- fix something from another module (duplicates were checked in (A))
 163    rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
 164
 165    -- Rename deprec decls;
 166    -- check for duplicates and ensure that deprecated things are defined locally
 167    -- at the moment, we don't keep these around past renaming
 168    rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
 169
 170    -- (H) Rename Everything else
 171
 172    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
 173    (rn_rule_decls,    src_fvs3) <- setXOptM Opt_ScopedTypeVariables $
 174                                    rnList rnHsRuleDecl    rule_decls ;
 175                            -- Inside RULES, scoped type variables are on
 176    (rn_vect_decls,    src_fvs4) <- rnList rnHsVectDecl    vect_decls ;
 177    (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ;
 178    (rn_ann_decls,     src_fvs6) <- rnList rnAnnDecl       ann_decls ;
 179    (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl   default_decls ;
 180    (rn_deriv_decls,   src_fvs8) <- rnList rnSrcDerivDecl  deriv_decls ;
 181       -- Haddock docs; no free vars
 182    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 183
 184    -- (I) Compute the results and return
 185    let {rn_group = HsGroup { hs_valds   = rn_val_decls,
 186                              hs_tyclds  = rn_tycl_decls,
 187                              hs_instds  = rn_inst_decls,
 188                              hs_derivds = rn_deriv_decls,
 189                              hs_fixds   = rn_fix_decls,
 190                              hs_warnds  = [], -- warns are returned in the tcg_env
 191                                              -- (see below) not in the HsGroup
 192                              hs_fords  = rn_foreign_decls,
 193                              hs_annds  = rn_ann_decls,
 194                              hs_defds  = rn_default_decls,
 195                              hs_ruleds = rn_rule_decls,
 196                              hs_vects  = rn_vect_decls,
 197                              hs_docs   = rn_docs } ;
 198
 199         tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
 200         ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
 201         other_def  = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
 202         other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
 203                               src_fvs5, src_fvs6, src_fvs7, src_fvs8] ;
 204                 -- It is tiresome to gather the binders from type and class decls
 205
 206         src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
 207                 -- Instance decls may have occurrences of things bound in bind_dus
 208                 -- so we must put other_fvs last
 209
 210         final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
 211                         in -- we return the deprecs in the env, not in the HsGroup above
 212                         tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
 213        } ;
 214
 215    traceRn (text "finish rnSrc" <+> ppr rn_group) ;
 216    traceRn (text "finish Dus" <+> ppr src_dus ) ;
 217    return (final_tcg_env, rn_group)
 218                     }}}}
 219
 220 -- some utils because we do this a bunch above
 221 -- compute and install the new env
 222 inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
 223 inNewEnv env cont = do e <- env
 224                        setGblEnv e $ cont e
 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         (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
 448     in
 449     extendTyVarEnvForMethodBinds inst_tyvars (
 450         -- (Slightly strangely) the forall-d tyvars scope over
 451         -- the method bindings too
 452         rnMethodBinds cls (\_ -> [])    -- No scoped tyvars
 453                       mbinds
 454     )                                           `thenM` \ (mbinds', meth_fvs) ->
 455         -- Rename the associated types
 456         -- The typechecker (not the renamer) checks that all
 457         -- the declarations are for the right class
 458     let
 459         at_names = map (tcdLName . unLoc) ats   -- The names of the associated types
 460     in
 461     checkDupRdrNames at_names           `thenM_`
 462         -- See notes with checkDupRdrNames for methods, above
 463
 464     rnATInsts ats                               `thenM` \ (ats', at_fvs) ->
 465
 466         -- Rename the prags and signatures.
 467         -- Note that the type variables are not in scope here,
 468         -- so that      instance Eq a => Eq (T a) where
 469         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 470         -- works OK.
 471         --
 472         -- But the (unqualified) method names are in scope
 473     let
 474         binders = collectHsBindsBinders mbinds'
 475         bndr_set = mkNameSet binders
 476     in
 477     bindLocalNames binders
 478         (renameSigs (Just bndr_set) okInstDclSig uprags)        `thenM` \ uprags' ->
 479
 480     return (InstDecl inst_ty' mbinds' uprags' ats',
 481              meth_fvs `plusFV` at_fvs
 482                       `plusFV` hsSigsFVs uprags'
 483                       `plusFV` extractHsTyNames inst_ty')
 484              -- We return the renamed associated data type declarations so
 485              -- that they can be entered into the list of type declarations
 486              -- for the binding group, but we also keep a copy in the instance.
 487              -- The latter is needed for well-formedness checks in the type
 488              -- checker (eg, to ensure that all ATs of the instance actually
 489              -- receive a declaration).
 490              -- NB: Even the copies in the instance declaration carry copies of
 491              --     the instance context after renaming.  This is a bit
 492              --     strange, but should not matter (and it would be more work
 493              --     to remove the context).
 494 \end{code}
 495
 496 Renaming of the associated types in instances.
 497
 498 \begin{code}
 499 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 500 rnATInsts atDecls = rnList rnATInst atDecls
 501   where
 502     rnATInst tydecl@TyData     {} = rnTyClDecl tydecl
 503     rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
 504     rnATInst tydecl               =
 505       pprPanic "RnSource.rnATInsts: invalid AT instance"
 506                (ppr (tcdName tydecl))
 507 \end{code}
 508
 509 For the method bindings in class and instance decls, we extend the
 510 type variable environment iff -fglasgow-exts
 511
 512 \begin{code}
 513 extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
 514                              -> RnM (Bag (LHsBind Name), FreeVars)
 515                              -> RnM (Bag (LHsBind Name), FreeVars)
 516 extendTyVarEnvForMethodBinds tyvars thing_inside
 517   = do  { scoped_tvs <- xoptM Opt_ScopedTypeVariables
 518         ; if scoped_tvs then
 519                 extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
 520           else
 521                 thing_inside }
 522 \end{code}
 523
 524 %*********************************************************
 525 %*                                                      *
 526 \subsection{Stand-alone deriving declarations}
 527 %*                                                      *
 528 %*********************************************************
 529
 530 \begin{code}
 531 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
 532 rnSrcDerivDecl (DerivDecl ty)
 533   = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
 534        ; unless standalone_deriv_ok (addErr standaloneDerivErr)
 535        ; ty' <- rnLHsType (text "In a deriving declaration") ty
 536        ; let fvs = extractHsTyNames ty'
 537        ; return (DerivDecl ty', fvs) }
 538
 539 standaloneDerivErr :: SDoc
 540 standaloneDerivErr
 541   = hang (ptext (sLit "Illegal standalone deriving declaration"))
 542        2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
 543 \end{code}
 544
 545 %*********************************************************
 546 %*                                                      *
 547 \subsection{Rules}
 548 %*                                                      *
 549 %*********************************************************
 550
 551 \begin{code}
 552 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
 553 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
 554   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
 555     bindLocatedLocalsFV (map get_var vars)              $ \ ids ->
 556     do  { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
 557                 -- NB: The binders in a rule are always Ids
 558                 --     We don't (yet) support type variables
 559
 560         ; (lhs', fv_lhs') <- rnLExpr lhs
 561         ; (rhs', fv_rhs') <- rnLExpr rhs
 562
 563         ; checkValidRule rule_name ids lhs' fv_lhs'
 564
 565         ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
 566                   fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
 567   where
 568     doc = text "In the transformation rule" <+> ftext rule_name
 569
 570     get_var (RuleBndr v)      = v
 571     get_var (RuleBndrSig v _) = v
 572
 573     rn_var (RuleBndr (L loc _), id)
 574         = return (RuleBndr (L loc id), emptyFVs)
 575     rn_var (RuleBndrSig (L loc _) t, id)
 576         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
 577           return (RuleBndrSig (L loc id) t', fvs)
 578
 579 badRuleVar :: FastString -> Name -> SDoc
 580 badRuleVar name var
 581   = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
 582          ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
 583                 ptext (sLit "does not appear on left hand side")]
 584 \end{code}
 585
 586 Note [Rule LHS validity checking]
 587 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 588 Check the shape of a transformation rule LHS.  Currently we only allow
 589 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
 590 @forall@'d variables.
 591
 592 We used restrict the form of the 'ei' to prevent you writing rules
 593 with LHSs with a complicated desugaring (and hence unlikely to match);
 594 (e.g. a case expression is not allowed: too elaborate.)
 595
 596 But there are legitimate non-trivial args ei, like sections and
 597 lambdas.  So it seems simmpler not to check at all, and that is why
 598 check_e is commented out.
 599
 600 \begin{code}
 601 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
 602 checkValidRule rule_name ids lhs' fv_lhs'
 603   = do  {       -- Check for the form of the LHS
 604           case (validRuleLhs ids lhs') of
 605                 Nothing  -> return ()
 606                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
 607
 608                 -- Check that LHS vars are all bound
 609         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
 610         ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
 611
 612 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 613 -- Nothing => OK
 614 -- Just e  => Not ok, and e is the offending expression
 615 validRuleLhs foralls lhs
 616   = checkl lhs
 617   where
 618     checkl (L _ e) = check e
 619
 620     check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
 621     check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
 622     check (HsVar v) | v `notElem` foralls = Nothing
 623     check other                           = Just other  -- Failure
 624
 625         -- Check an argument
 626     checkl_e (L _ _e) = Nothing         -- Was (check_e e); see Note [Rule LHS validity checking]
 627
 628 {-      Commented out; see Note [Rule LHS validity checking] above
 629     check_e (HsVar v)     = Nothing
 630     check_e (HsPar e)     = checkl_e e
 631     check_e (HsLit e)     = Nothing
 632     check_e (HsOverLit e) = Nothing
 633
 634     check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
 635     check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
 636     check_e (NegApp e _)         = checkl_e e
 637     check_e (ExplicitList _ es)  = checkl_es es
 638     check_e other                = Just other   -- Fails
 639
 640     checkl_es es = foldr (mplus . checkl_e) Nothing es
 641 -}
 642
 643 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
 644 badRuleLhsErr name lhs bad_e
 645   = sep [ptext (sLit "Rule") <+> ftext name <> colon,
 646          nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e,
 647                        ptext (sLit "in left-hand side:") <+> ppr lhs])]
 648     $$
 649     ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
 650 \end{code}
 651
 652
 653 %*********************************************************
 654 %*                                                      *
 655 \subsection{Vectorisation declarations}
 656 %*                                                      *
 657 %*********************************************************
 658
 659 \begin{code}
 660 rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
 661 rnHsVectDecl (HsVect var Nothing)
 662   = do { var' <- wrapLocM lookupTopBndrRn var
 663        ; return (HsVect var' Nothing, unitFV (unLoc var'))
 664        }
 665 rnHsVectDecl (HsVect var (Just rhs))
 666   = do { var' <- wrapLocM lookupTopBndrRn var
 667        ; (rhs', fv_rhs) <- rnLExpr rhs
 668        ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var')
 669        }
 670 rnHsVectDecl (HsNoVect var)
 671   = do { var' <- wrapLocM lookupTopBndrRn var
 672        ; return (HsNoVect var', unitFV (unLoc var'))
 673        }
 674 \end{code}
 675
 676 %*********************************************************
 677 %*                                                      *
 678 \subsection{Type, class and iface sig declarations}
 679 %*                                                      *
 680 %*********************************************************
 681
 682 @rnTyDecl@ uses the `global name function' to create a new type
 683 declaration in which local names have been replaced by their original
 684 names, reporting any unknown names.
 685
 686 Renaming type variables is a pain. Because they now contain uniques,
 687 it is necessary to pass in an association list which maps a parsed
 688 tyvar to its @Name@ representation.
 689 In some cases (type signatures of values),
 690 it is even necessary to go over the type first
 691 in order to get the set of tyvars used by it, make an assoc list,
 692 and then go over it again to rename the tyvars!
 693 However, we can also do some scoping checks at the same time.
 694
 695 \begin{code}
 696 rnTyClDecls :: [[LTyClDecl RdrName]] -> RnM ([[LTyClDecl Name]], FreeVars)
 697 -- Renamed the declarations and do depedency analysis on them
 698 rnTyClDecls tycl_ds
 699   = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds)
 700
 701        ; let sccs :: [SCC (LTyClDecl Name)]
 702              sccs = depAnalTyClDecls ds_w_fvs
 703
 704              all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs
 705
 706        ; return (map flattenSCC sccs, all_fvs) }
 707
 708 rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
 709 rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
 710   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 711     return (ForeignType {tcdLName = name', tcdExtName = ext_name},
 712              emptyFVs)
 713
 714 -- all flavours of type family declarations ("type family", "newtype fanily",
 715 -- and "data family")
 716 rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV
 717
 718 -- "data", "newtype", "data instance, and "newtype instance" declarations
 719 rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 720                            tcdLName = tycon, tcdTyVars = tyvars,
 721                            tcdTyPats = typats, tcdCons = condecls,
 722                            tcdKindSig = sig, tcdDerivs = derivs}
 723   = do  { tycon' <- if isFamInstDecl tydecl
 724                     then lookupLocatedOccRn     tycon -- may be imported family
 725                     else lookupLocatedTopBndrRn tycon
 726         ; checkTc (h98_style || null (unLoc context))
 727                   (badGadtStupidTheta tycon)
 728         ; ((tyvars', context', typats', derivs'), stuff_fvs)
 729                 <- bindTyVarsFV tyvars $ \ tyvars' -> do
 730                                  -- Checks for distinct tyvars
 731                    { context' <- rnContext data_doc context
 732                    ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
 733                    ; (derivs', fvs2) <- rn_derivs derivs
 734                    ; let fvs = fvs1 `plusFV` fvs2 `plusFV`
 735                                extractHsCtxtTyNames context'
 736                    ; return ((tyvars', context', typats', derivs'), fvs) }
 737
 738         -- For the constructor declarations, bring into scope the tyvars
 739         -- bound by the header, but *only* in the H98 case
 740         -- Reason: for GADTs, the type variables in the declaration
 741         --   do not scope over the constructor signatures
 742         --   data T a where { T1 :: forall b. b-> b }
 743         ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
 744                               | otherwise = []
 745         ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
 746                                   rnConDecls condecls
 747                 -- No need to check for duplicate constructor decls
 748                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 749
 750         ; return (TyData {tcdND = new_or_data, tcdCtxt = context',
 751                            tcdLName = tycon', tcdTyVars = tyvars',
 752                            tcdTyPats = typats', tcdKindSig = sig,
 753                            tcdCons = condecls', tcdDerivs = derivs'},
 754                    con_fvs `plusFV` stuff_fvs)
 755         }
 756   where
 757     h98_style = case condecls of         -- Note [Stupid theta]
 758                      L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
 759                      _                                             -> True
 760
 761     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 762
 763     rn_derivs Nothing   = return (Nothing, emptyFVs)
 764     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 765                           return (Just ds', extractHsTyNames_s ds')
 766
 767 -- "type" and "type instance" declarations
 768 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
 769                               tcdTyPats = typats, tcdSynRhs = ty})
 770   = bindTyVarsFV tyvars $ \ tyvars' -> do
 771     {            -- Checks for distinct tyvars
 772       name' <- if isFamInstDecl tydecl
 773                   then lookupLocatedOccRn     name -- may be imported family
 774                   else lookupLocatedTopBndrRn name
 775     ; (typats',fvs1) <- rnTyPats syn_doc name' typats
 776     ; (ty', fvs2)    <- rnHsTypeFVs syn_doc ty
 777     ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
 778                         , tcdTyPats = typats', tcdSynRhs = ty'},
 779               fvs1 `plusFV` fvs2) }
 780   where
 781     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 782
 783 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 784                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 785                        tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
 786   = do  { cname' <- lookupLocatedTopBndrRn cname
 787
 788         -- Tyvars scope over superclass context and method signatures
 789         ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
 790             <- bindTyVarsFV tyvars $ \ tyvars' -> do
 791                  -- Checks for distinct tyvars
 792              { context' <- rnContext cls_doc context
 793              ; fds' <- rnFds cls_doc fds
 794              ; (ats', at_fvs) <- rnATs ats
 795              ; sigs' <- renameSigs Nothing okClsDclSig sigs
 796              ; let fvs = at_fvs `plusFV`
 797                          extractHsCtxtTyNames context'  `plusFV`
 798                          hsSigsFVs sigs'
 799                          -- The fundeps have no free variables
 800              ; return ((tyvars', context', fds', ats', sigs'), fvs) }
 801
 802         -- No need to check for duplicate associated type decls
 803         -- since that is done by RnNames.extendGlobalRdrEnvRn
 804
 805         -- Check the signatures
 806         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 807         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops]
 808         ; checkDupRdrNames sig_rdr_names_w_locs
 809                 -- Typechecker is responsible for checking that we only
 810                 -- give default-method bindings for things in this class.
 811                 -- The renamer *could* check this for class decls, but can't
 812                 -- for instance decls.
 813
 814         -- The newLocals call is tiresome: given a generic class decl
 815         --      class C a where
 816         --        op :: a -> a
 817         --        op {| x+y |} (Inl a) = ...
 818         --        op {| x+y |} (Inr b) = ...
 819         --        op {| a*b |} (a*b)   = ...
 820         -- we want to name both "x" tyvars with the same unique, so that they are
 821         -- easy to group together in the typechecker.
 822         ; (mbinds', meth_fvs)
 823             <- extendTyVarEnvForMethodBinds tyvars' $
 824                 -- No need to check for duplicate method signatures
 825                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 826                 -- and the methods are already in scope
 827                  rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds
 828
 829   -- Haddock docs
 830         ; docs' <- mapM (wrapLocM rnDocDecl) docs
 831
 832         ; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
 833                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
 834                               tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
 835                   meth_fvs `plusFV` stuff_fvs) }
 836   where
 837     cls_doc  = text "In the declaration for class"      <+> ppr cname
 838
 839 badGadtStupidTheta :: Located RdrName -> SDoc
 840 badGadtStupidTheta _
 841   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
 842           ptext (sLit "(You can put a context on each contructor, though.)")]
 843 \end{code}
 844
 845 Note [Stupid theta]
 846 ~~~~~~~~~~~~~~~~~~~
 847 Trac #3850 complains about a regression wrt 6.10 for
 848      data Show a => T a
 849 There is no reason not to allow the stupid theta if there are no data
 850 constructors.  It's still stupid, but does no harm, and I don't want
 851 to cause programs to break unnecessarily (notably HList).  So if there
 852 are no data constructors we allow h98_style = True
 853
 854
 855 \begin{code}
 856 depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
 857 -- See Note [Dependency analysis of type and class decls]
 858 depAnalTyClDecls ds_w_fvs
 859   = stronglyConnCompFromEdgedVertices edges
 860   where
 861     edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs))
 862             | (d, fvs) <- ds_w_fvs ]
 863     get_assoc n = lookupNameEnv assoc_env n `orElse` n
 864     assoc_env = mkNameEnv [ (tcdName assoc_decl, cls_name)
 865                           | (L _ (ClassDecl { tcdLName = L _ cls_name
 866                                             , tcdATs   = ats }) ,_) <- ds_w_fvs
 867                           , L _ assoc_decl <- ats ]
 868 \end{code}
 869
 870 Note [Dependency analysis of type and class decls]
 871 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 872 We need to do dependency analysis on type and class declarations
 873 else we get bad error messages.  Consider
 874
 875      data T f a = MkT f a
 876      data S f a = MkS f (T f a)
 877
 878 This has a kind error, but the error message is better if you
 879 check T first, (fixing its kind) and *then* S.  If you do kind
 880 inference together, you might get an error reported in S, which
 881 is jolly confusing.  See Trac #4875
 882
 883
 884 %*********************************************************
 885 %*                                                      *
 886 \subsection{Support code for type/data declarations}
 887 %*                                                      *
 888 %*********************************************************
 889
 890 \begin{code}
 891 rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
 892 -- Although, we are processing type patterns here, all type variables will
 893 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 894 -- type declaration to which these patterns belong)
 895 rnTyPats _   _  Nothing
 896   = return (Nothing, emptyFVs)
 897 rnTyPats doc tc (Just typats)
 898   = do { typats' <- rnLHsTypes doc typats
 899        ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc)
 900              -- type instance => use, hence addOneFV
 901        ; return (Just typats', fvs) }
 902
 903 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
 904 rnConDecls condecls
 905   = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
 906        ; return (condecls', plusFVs (map conDeclFVs condecls')) }
 907
 908 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 909 rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
 910                                , con_cxt = cxt, con_details = details
 911                                , con_res = res_ty, con_doc = mb_doc
 912                                , con_old_rec = old_rec, con_explicit = expl })
 913   = do  { addLocM checkConName name
 914         ; when old_rec (addWarn (deprecRecSyntax decl))
 915         ; new_name <- lookupLocatedTopBndrRn name
 916
 917            -- For H98 syntax, the tvs are the existential ones
 918            -- For GADT syntax, the tvs are all the quantified tyvars
 919            -- Hence the 'filter' in the ResTyH98 case only
 920         ; rdr_env <- getLocalRdrEnv
 921         ; let in_scope     = (`elemLocalRdrEnv` rdr_env) . unLoc
 922               arg_tys      = hsConDeclArgTys details
 923               mentioned_tvs = case res_ty of
 924                                ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
 925                                ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 926
 927          -- With an Explicit forall, check for unused binders
 928          -- With Implicit, find the mentioned ones, and use them as binders
 929         ; new_tvs <- case expl of
 930                        Implicit -> return (userHsTyVarBndrs mentioned_tvs)
 931                        Explicit -> do { warnUnusedForAlls doc tvs mentioned_tvs
 932                                       ; return tvs }
 933
 934         ; mb_doc' <- rnMbLHsDoc mb_doc
 935
 936         ; bindTyVarsRn new_tvs $ \new_tyvars -> do
 937         { new_context <- rnContext doc cxt
 938         ; new_details <- rnConDeclDetails doc details
 939         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
 940         ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
 941                        , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
 942  where
 943     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 944     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 945
 946 rnConResult :: SDoc
 947             -> HsConDetails (LHsType Name) [ConDeclField Name]
 948             -> ResType RdrName
 949             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
 950                     ResType Name)
 951 rnConResult _ details ResTyH98 = return (details, ResTyH98)
 952 rnConResult doc details (ResTyGADT ty)
 953   = do { ty' <- rnLHsType doc ty
 954        ; let (arg_tys, res_ty) = splitHsFunType ty'
 955                 -- We can finally split it up,
 956                 -- now the renamer has dealt with fixities
 957                 -- See Note [Sorting out the result type] in RdrHsSyn
 958
 959              details' = case details of
 960                            RecCon {}    -> details
 961                            PrefixCon {} -> PrefixCon arg_tys
 962                            InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
 963                           -- See Note [Sorting out the result type] in RdrHsSyn
 964
 965        ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
 966               (addErr (badRecResTy doc))
 967        ; return (details', ResTyGADT res_ty) }
 968
 969 rnConDeclDetails :: SDoc
 970                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
 971                  -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
 972 rnConDeclDetails doc (PrefixCon tys)
 973   = mapM (rnLHsType doc) tys    `thenM` \ new_tys  ->
 974     return (PrefixCon new_tys)
 975
 976 rnConDeclDetails doc (InfixCon ty1 ty2)
 977   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 978     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 979     return (InfixCon new_ty1 new_ty2)
 980
 981 rnConDeclDetails doc (RecCon fields)
 982   = do  { new_fields <- rnConDeclFields doc fields
 983                 -- No need to check for duplicate fields
 984                 -- since that is done by RnNames.extendGlobalRdrEnvRn
 985         ; return (RecCon new_fields) }
 986
 987 -- Rename family declarations
 988 --
 989 -- * This function is parametrised by the routine handling the index
 990 --   variables.  On the toplevel, these are defining occurences, whereas they
 991 --   are usage occurences for associated types.
 992 --
 993 rnFamily :: TyClDecl RdrName
 994          -> ([LHsTyVarBndr RdrName] ->
 995              ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 996              RnM (TyClDecl Name, FreeVars))
 997          -> RnM (TyClDecl Name, FreeVars)
 998
 999 rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
1000                            tcdLName = tycon, tcdTyVars = tyvars})
1001         bindIdxVars =
1002       do { bindIdxVars tyvars $ \tyvars' -> do {
1003          ; tycon' <- lookupLocatedTopBndrRn tycon
1004          ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
1005                               tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
1006                     emptyFVs)
1007          } }
1008 rnFamily d _ = pprPanic "rnFamily" (ppr d)
1009
1010 -- Rename associated type declarations (in classes)
1011 --
1012 -- * This can be family declarations and (default) type instances
1013 --
1014 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
1015 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
1016   where
1017     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
1018     rn_at (tydecl@TySynonym {}) =
1019       do
1020         unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
1021         rnTyClDecl tydecl
1022     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
1023
1024     lookupIdxVars tyvars cont =
1025       do { checkForDups tyvars
1026          ; tyvars' <- mapM lookupIdxVar tyvars
1027          ; cont tyvars'
1028          }
1029     -- Type index variables must be class parameters, which are the only
1030     -- type variables in scope at this point.
1031     lookupIdxVar (L l tyvar) =
1032       do
1033         name' <- lookupOccRn (hsTyVarName tyvar)
1034         return $ L l (replaceTyVarName tyvar name')
1035
1036     -- Type variable may only occur once.
1037     --
1038     checkForDups [] = return ()
1039     checkForDups (L loc tv:ltvs) =
1040       do { setSrcSpan loc $
1041              when (hsTyVarName tv `ltvElem` ltvs) $
1042                addErr (repeatedTyVar tv)
1043          ; checkForDups ltvs
1044          }
1045
1046     _       `ltvElem` [] = False
1047     rdrName `ltvElem` (L _ tv:ltvs)
1048       | rdrName == hsTyVarName tv = True
1049       | otherwise                 = rdrName `ltvElem` ltvs
1050
1051 deprecRecSyntax :: ConDecl RdrName -> SDoc
1052 deprecRecSyntax decl
1053   = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
1054                  <+> ptext (sLit "uses deprecated syntax")
1055          , ptext (sLit "Instead, use the form")
1056          , nest 2 (ppr decl) ]   -- Pretty printer uses new form
1057
1058 badRecResTy :: SDoc -> SDoc
1059 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
1060
1061 noPatterns :: SDoc
1062 noPatterns = text "Default definition for an associated synonym cannot have"
1063              <+> text "type pattern"
1064
1065 repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
1066 repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
1067                    quotes (ppr tv)
1068
1069 -- This data decl will parse OK
1070 --      data T = a Int
1071 -- treating "a" as the constructor.
1072 -- It is really hard to make the parser spot this malformation.
1073 -- So the renamer has to check that the constructor is legal
1074 --
1075 -- We can get an operator as the constructor, even in the prefix form:
1076 --      data T = :% Int Int
1077 -- from interface files, which always print in prefix form
1078
1079 checkConName :: RdrName -> TcRn ()
1080 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
1081
1082 badDataCon :: RdrName -> SDoc
1083 badDataCon name
1084    = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
1085 \end{code}
1086
1087
1088 %*********************************************************
1089 %*                                                      *
1090 \subsection{Support code for type/data declarations}
1091 %*                                                      *
1092 %*********************************************************
1093
1094 Get the mapping from constructors to fields for this module.
1095 It's convenient to do this after the data type decls have been renamed
1096 \begin{code}
1097 extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv
1098 extendRecordFieldEnv tycl_decls inst_decls
1099   = do  { tcg_env <- getGblEnv
1100         ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
1101         ; return (tcg_env { tcg_field_env = field_env' }) }
1102   where
1103     -- we want to lookup:
1104     --  (a) a datatype constructor
1105     --  (b) a record field
1106     -- knowing that they're from this module.
1107     -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
1108     -- which keeps only the local ones.
1109     lookup x = do { x' <- lookupLocatedTopBndrRn x
1110                     ; return $ unLoc x'}
1111
1112     all_data_cons :: [ConDecl RdrName]
1113     all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
1114                          , L _ con <- cons ]
1115     all_tycl_decls = at_tycl_decls ++ concat tycl_decls
1116     at_tycl_decls = instDeclATs inst_decls  -- Do not forget associated types!
1117
1118     get_con (ConDecl { con_name = con, con_details = RecCon flds })
1119             (RecFields env fld_set)
1120         = do { con' <- lookup con
1121              ; flds' <- mapM lookup (map cd_fld_name flds)
1122              ; let env'    = extendNameEnv env con' flds'
1123                    fld_set' = addListToNameSet fld_set flds'
1124              ; return $ (RecFields env' fld_set') }
1125     get_con _ env = return env
1126 \end{code}
1127
1128 %*********************************************************
1129 %*                                                      *
1130 \subsection{Support code to rename types}
1131 %*                                                      *
1132 %*********************************************************
1133
1134 \begin{code}
1135 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
1136
1137 rnFds doc fds
1138   = mapM (wrapLocM rn_fds) fds
1139   where
1140     rn_fds (tys1, tys2)
1141       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
1142         rnHsTyVars doc tys2             `thenM` \ tys2' ->
1143         return (tys1', tys2')
1144
1145 rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
1146 rnHsTyVars doc tvs  = mapM (rnHsTyVar doc) tvs
1147
1148 rnHsTyVar :: SDoc -> RdrName -> RnM Name
1149 rnHsTyVar _doc tyvar = lookupOccRn tyvar
1150 \end{code}
1151
1152
1153 %*********************************************************
1154 %*                                                      *
1155         findSplice
1156 %*                                                      *
1157 %*********************************************************
1158
1159 This code marches down the declarations, looking for the first
1160 Template Haskell splice.  As it does so it
1161         a) groups the declarations into a HsGroup
1162         b) runs any top-level quasi-quotes
1163
1164 \begin{code}
1165 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1166 findSplice ds = addl emptyRdrGroup ds
1167
1168 addl :: HsGroup RdrName -> [LHsDecl RdrName]
1169      -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1170 -- This stuff reverses the declarations (again) but it doesn't matter
1171 addl gp []           = return (gp, Nothing)
1172 addl gp (L l d : ds) = add gp l d ds
1173
1174
1175 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
1176     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1177
1178 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
1179   = do { -- We've found a top-level splice.  If it is an *implicit* one
1180          -- (i.e. a naked top level expression)
1181          case flag of
1182            Explicit -> return ()
1183            Implicit -> do { th_on <- xoptM Opt_TemplateHaskell
1184                           ; unless th_on $ setSrcSpan loc $
1185                             failWith badImplicitSplice }
1186
1187        ; return (gp, Just (splice, ds)) }
1188   where
1189     badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
1190
1191 #ifndef GHCI
1192 add _ _ (QuasiQuoteD qq) _
1193   = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq)
1194 #else
1195 add gp _ (QuasiQuoteD qq) ds            -- Expand quasiquotes
1196   = do { ds' <- runQuasiQuoteDecl qq
1197        ; addl gp (ds' ++ ds) }
1198 #endif
1199
1200 -- Class declarations: pull out the fixity signatures to the top
1201 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
1202   | isClassDecl d
1203   = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
1204     addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
1205   | otherwise
1206   = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
1207
1208 -- Signatures: fixity sigs go a different place than all others
1209 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
1210   = addl (gp {hs_fixds = L l f : ts}) ds
1211 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
1212   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
1213
1214 -- Value declarations: use add_bind
1215 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
1216   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
1217
1218 -- The rest are routine
1219 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
1220   = addl (gp { hs_instds = L l d : ts }) ds
1221 add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
1222   = addl (gp { hs_derivds = L l d : ts }) ds
1223 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
1224   = addl (gp { hs_defds = L l d : ts }) ds
1225 add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
1226   = addl (gp { hs_fords = L l d : ts }) ds
1227 add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
1228   = addl (gp { hs_warnds = L l d : ts }) ds
1229 add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
1230   = addl (gp { hs_annds = L l d : ts }) ds
1231 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
1232   = addl (gp { hs_ruleds = L l d : ts }) ds
1233 add gp@(HsGroup {hs_vects  = ts}) l (VectD d) ds
1234   = addl (gp { hs_vects = L l d : ts }) ds
1235 add gp l (DocD d) ds
1236   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
1237
1238 add_tycld :: LTyClDecl a -> [[LTyClDecl a]] -> [[LTyClDecl a]]
1239 add_tycld d []       = [[d]]
1240 add_tycld d (ds:dss) = (d:ds) : dss
1241
1242 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
1243 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
1244 add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
1245
1246 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
1247 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
1248 add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
1249 \end{code}