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