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