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 )
  20 import RdrHsSyn         ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
  21 import RnHsSyn
  22 import RnTypes          ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
  23 import RnBinds          ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
  24 import RnEnv            ( lookupLocalDataTcNames,
  25                           lookupLocatedTopBndrRn, lookupLocatedOccRn,
  26                           lookupOccRn, newLocalsRn,
  27                           bindLocatedLocalsFV, bindPatSigTyVarsFV,
  28                           bindTyVarsRn, extendTyVarEnvFVRn,
  29                           bindLocalNames, checkDupNames, mapFvRn
  30                         )
  31 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
  32 import TcRnMonad
  33
  34 import HscTypes         ( FixityEnv, FixItem(..), Deprecations, Deprecs(..), plusDeprecs )
  35 import Class            ( FunDep )
  36 import Name             ( Name, nameOccName )
  37 import NameSet
  38 import NameEnv
  39 import OccName          ( occEnvElts )
  40 import Outputable
  41 import SrcLoc           ( Located(..), unLoc, noLoc )
  42 import DynFlags ( DynFlag(..) )
  43 import Maybes           ( seqMaybe )
  44 import Maybe            ( isNothing )
  45 import Monad            ( liftM, when )
  46 import BasicTypes       ( Boxity(..) )
  47 \end{code}
  48
  49 @rnSourceDecl@ `renames' declarations.
  50 It simultaneously performs dependency analysis and precedence parsing.
  51 It also does the following error checks:
  52 \begin{enumerate}
  53 \item
  54 Checks that tyvars are used properly. This includes checking
  55 for undefined tyvars, and tyvars in contexts that are ambiguous.
  56 (Some of this checking has now been moved to module @TcMonoType@,
  57 since we don't have functional dependency information at this point.)
  58 \item
  59 Checks that all variable occurences are defined.
  60 \item
  61 Checks the @(..)@ etc constraints in the export list.
  62 \end{enumerate}
  63
  64
  65 \begin{code}
  66 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
  67
  68 rnSrcDecls (HsGroup { hs_valds  = val_decls,
  69                       hs_tyclds = tycl_decls,
  70                       hs_instds = inst_decls,
  71                       hs_derivds = deriv_decls,
  72                       hs_fixds  = fix_decls,
  73                       hs_depds  = deprec_decls,
  74                       hs_fords  = foreign_decls,
  75                       hs_defds  = default_decls,
  76                       hs_ruleds = rule_decls,
  77           hs_docs   = docs })
  78
  79  = do {         -- Deal with deprecations (returns only the extra deprecations)
  80         deprecs <- rnSrcDeprecDecls deprec_decls ;
  81         updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
  82                   $ do {
  83
  84                 -- Deal with top-level fixity decls
  85                 -- (returns the total new fixity env)
  86         rn_fix_decls <- rnSrcFixityDecls fix_decls ;
  87         fix_env <- rnSrcFixityDeclsEnv rn_fix_decls ;
  88         updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
  89                   $ do {
  90
  91                 -- Rename other declarations
  92         traceRn (text "Start rnmono") ;
  93         (rn_val_decls, bind_dus) <- rnTopBinds val_decls ;
  94         traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
  95
  96                 -- You might think that we could build proper def/use information
  97                 -- for type and class declarations, but they can be involved
  98                 -- in mutual recursion across modules, and we only do the SCC
  99                 -- analysis for them in the type checker.
 100                 -- So we content ourselves with gathering uses only; that
 101                 -- means we'll only report a declaration as unused if it isn't
 102                 -- mentioned at all.  Ah well.
 103         traceRn (text "Start rnTyClDecls") ;
 104         (rn_tycl_decls,    src_fvs1)
 105            <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
 106         traceRn (text "finish rnTyClDecls") ;
 107         (rn_inst_decls,    src_fvs2)
 108            <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
 109         (rn_deriv_decls,    src_fvs_deriv)
 110            <- mapFvRn (wrapLocFstM rnSrcDerivDecl) deriv_decls ;
 111         (rn_rule_decls,    src_fvs3)
 112            <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
 113         (rn_foreign_decls, src_fvs4)
 114            <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
 115         (rn_default_decls, src_fvs5)
 116            <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
 117
 118   -- Haddock docs
 119         rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 120
 121         let {
 122            rn_group = HsGroup { hs_valds  = rn_val_decls,
 123                                 hs_tyclds = rn_tycl_decls,
 124                                 hs_instds = rn_inst_decls,
 125                                 hs_derivds = rn_deriv_decls,
 126                                 hs_fixds  = rn_fix_decls,
 127                                 hs_depds  = [],
 128                                 hs_fords  = rn_foreign_decls,
 129                                 hs_defds  = rn_default_decls,
 130                                 hs_ruleds = rn_rule_decls,
 131             hs_docs   = rn_docs } ;
 132
 133            other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3,
 134                                 src_fvs4, src_fvs5] ;
 135            src_dus = bind_dus `plusDU` usesOnly other_fvs
 136                 -- Note: src_dus will contain *uses* for locally-defined types
 137                 -- and classes, but no *defs* for them.  (Because rnTyClDecl
 138                 -- returns only the uses.)  This is a little
 139                 -- surprising but it doesn't actually matter at all.
 140         } ;
 141
 142         traceRn (text "finish rnSrc" <+> ppr rn_group) ;
 143         traceRn (text "finish Dus" <+> ppr src_dus ) ;
 144         tcg_env <- getGblEnv ;
 145         return (tcg_env `addTcgDUs` src_dus, rn_group)
 146     }}}
 147
 148 rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
 149 rnTyClDecls tycl_decls = do
 150   (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
 151   return decls'
 152
 153 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
 154 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
 155 \end{code}
 156
 157
 158 %*********************************************************
 159 %*                                                       *
 160         HsDoc stuff
 161 %*                                                       *
 162 %*********************************************************
 163
 164 \begin{code}
 165 rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
 166 rnDocDecl (DocCommentNext doc) = do
 167   rn_doc <- rnHsDoc doc
 168   return (DocCommentNext rn_doc)
 169 rnDocDecl (DocCommentPrev doc) = do
 170   rn_doc <- rnHsDoc doc
 171   return (DocCommentPrev rn_doc)
 172 rnDocDecl (DocCommentNamed str doc) = do
 173   rn_doc <- rnHsDoc doc
 174   return (DocCommentNamed str rn_doc)
 175 rnDocDecl (DocGroup lev doc) = do
 176   rn_doc <- rnHsDoc doc
 177   return (DocGroup lev rn_doc)
 178 \end{code}
 179
 180
 181 %*********************************************************
 182 %*                                                       *
 183         Source-code fixity declarations
 184 %*                                                       *
 185 %*********************************************************
 186
 187 \begin{code}
 188 rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name]
 189 rnSrcFixityDecls fix_decls
 190     = do fix_decls <- mapM rnFixityDecl fix_decls
 191          return (concat fix_decls)
 192
 193 rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name]
 194 rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity))
 195     = setSrcSpan nameLoc $
 196         -- GHC extension: look up both the tycon and data con
 197         -- for con-like things
 198         -- If neither are in scope, report an error; otherwise
 199         -- add both to the fixity env
 200       do names <- lookupLocalDataTcNames rdr_name
 201          return [ L loc (FixitySig (L nameLoc name) fixity)
 202                       | name <- names ]
 203
 204 rnSrcFixityDeclsEnv :: [LFixitySig Name] -> RnM FixityEnv
 205 rnSrcFixityDeclsEnv fix_decls
 206   = getGblEnv                                   `thenM` \ gbl_env ->
 207     foldlM rnFixityDeclEnv (tcg_fix_env gbl_env)
 208             fix_decls                                   `thenM` \ fix_env ->
 209     traceRn (text "fixity env" <+> pprFixEnv fix_env)   `thenM_`
 210     returnM fix_env
 211
 212 rnFixityDeclEnv :: FixityEnv -> LFixitySig Name -> RnM FixityEnv
 213 rnFixityDeclEnv fix_env (L loc (FixitySig (L nameLoc name) fixity))
 214   = case lookupNameEnv fix_env name of
 215       Just (FixItem _ _ loc')
 216           -> do addLocErr (L nameLoc name) (dupFixityDecl loc')
 217                 return fix_env
 218       Nothing
 219           -> return (extendNameEnv fix_env name fix_item)
 220     where fix_item = FixItem (nameOccName name) fixity nameLoc
 221
 222 pprFixEnv :: FixityEnv -> SDoc
 223 pprFixEnv env
 224   = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n)
 225                   (nameEnvElts env)
 226
 227 dupFixityDecl loc rdr_name
 228   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
 229           ptext SLIT("also at ") <+> ppr loc
 230         ]
 231 \end{code}
 232
 233
 234 %*********************************************************
 235 %*                                                       *
 236         Source-code deprecations declarations
 237 %*                                                       *
 238 %*********************************************************
 239
 240 For deprecations, all we do is check that the names are in scope.
 241 It's only imported deprecations, dealt with in RnIfaces, that we
 242 gather them together.
 243
 244 \begin{code}
 245 rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
 246 rnSrcDeprecDecls []
 247   = returnM NoDeprecs
 248
 249 rnSrcDeprecDecls decls
 250   = mappM (addLocM rn_deprec) decls     `thenM` \ pairs_s ->
 251     returnM (DeprecSome (mkNameEnv (concat pairs_s)))
 252  where
 253    rn_deprec (Deprecation rdr_name txt)
 254      = lookupLocalDataTcNames rdr_name  `thenM` \ names ->
 255        returnM [(name, (nameOccName name, txt)) | name <- names]
 256 \end{code}
 257
 258 %*********************************************************
 259 %*                                                      *
 260 \subsection{Source code declarations}
 261 %*                                                      *
 262 %*********************************************************
 263
 264 \begin{code}
 265 rnDefaultDecl (DefaultDecl tys)
 266   = mapFvRn (rnHsTypeFVs doc_str) tys   `thenM` \ (tys', fvs) ->
 267     returnM (DefaultDecl tys', fvs)
 268   where
 269     doc_str = text "In a `default' declaration"
 270 \end{code}
 271
 272 %*********************************************************
 273 %*                                                      *
 274 \subsection{Foreign declarations}
 275 %*                                                      *
 276 %*********************************************************
 277
 278 \begin{code}
 279 rnHsForeignDecl (ForeignImport name ty spec)
 280   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 281     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 282     returnM (ForeignImport name' ty' spec, fvs)
 283
 284 rnHsForeignDecl (ForeignExport name ty spec)
 285   = lookupLocatedOccRn name             `thenM` \ name' ->
 286     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 287     returnM (ForeignExport name' ty' spec, fvs )
 288         -- NB: a foreign export is an *occurrence site* for name, so
 289         --     we add it to the free-variable list.  It might, for example,
 290         --     be imported from another module
 291
 292 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
 293 \end{code}
 294
 295
 296 %*********************************************************
 297 %*                                                      *
 298 \subsection{Instance declarations}
 299 %*                                                      *
 300 %*********************************************************
 301
 302 \begin{code}
 303 rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 304         -- Used for both source and interface file decls
 305   = rnHsSigType (text "an instance decl") inst_ty       `thenM` \ inst_ty' ->
 306
 307         -- Rename the associated types
 308         -- The typechecker (not the renamer) checks that all
 309         -- the declarations are for the right class
 310     let
 311         at_doc   = text "In the associated types of an instance declaration"
 312         at_names = map (head . tyClDeclNames . unLoc) ats
 313     in
 314     checkDupNames at_doc at_names               `thenM_`
 315     rnATInsts ats                               `thenM` \ (ats', at_fvs) ->
 316
 317         -- Rename the bindings
 318         -- The typechecker (not the renamer) checks that all
 319         -- the bindings are for the right class
 320     let
 321         meth_doc    = text "In the bindings in an instance declaration"
 322         meth_names  = collectHsBindLocatedBinders mbinds
 323         (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
 324     in
 325     checkDupNames meth_doc meth_names   `thenM_`
 326     extendTyVarEnvForMethodBinds inst_tyvars (
 327         -- (Slightly strangely) the forall-d tyvars scope over
 328         -- the method bindings too
 329         rnMethodBinds cls (\n->[])      -- No scoped tyvars
 330                       [] mbinds
 331     )                                           `thenM` \ (mbinds', meth_fvs) ->
 332         -- Rename the prags and signatures.
 333         -- Note that the type variables are not in scope here,
 334         -- so that      instance Eq a => Eq (T a) where
 335         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 336         -- works OK.
 337         --
 338         -- But the (unqualified) method names are in scope
 339     let
 340         binders = collectHsBindBinders mbinds'
 341         ok_sig  = okInstDclSig (mkNameSet binders)
 342     in
 343     bindLocalNames binders (renameSigs ok_sig uprags)   `thenM` \ uprags' ->
 344
 345     returnM (InstDecl inst_ty' mbinds' uprags' ats',
 346              meth_fvs `plusFV` at_fvs
 347                       `plusFV` hsSigsFVs uprags'
 348                       `plusFV` extractHsTyNames inst_ty')
 349              -- We return the renamed associated data type declarations so
 350              -- that they can be entered into the list of type declarations
 351              -- for the binding group, but we also keep a copy in the instance.
 352              -- The latter is needed for well-formedness checks in the type
 353              -- checker (eg, to ensure that all ATs of the instance actually
 354              -- receive a declaration).
 355              -- NB: Even the copies in the instance declaration carry copies of
 356              --     the instance context after renaming.  This is a bit
 357              --     strange, but should not matter (and it would be more work
 358              --     to remove the context).
 359 \end{code}
 360
 361 Renaming of the associated types in instances.
 362
 363 \begin{code}
 364 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 365 rnATInsts atDecls =
 366   mapFvRn (wrapLocFstM rnATInst) atDecls
 367   where
 368     rnATInst tydecl@TyData     {} = rnTyClDecl tydecl
 369     rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
 370     rnATInst tydecl               =
 371       pprPanic "RnSource.rnATInsts: invalid AT instance"
 372                (ppr (tcdName tydecl))
 373 \end{code}
 374
 375 For the method bindings in class and instance decls, we extend the
 376 type variable environment iff -fglasgow-exts
 377
 378 \begin{code}
 379 extendTyVarEnvForMethodBinds tyvars thing_inside
 380   = doptM Opt_GlasgowExts                       `thenM` \ opt_GlasgowExts ->
 381     if opt_GlasgowExts then
 382         extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
 383     else
 384         thing_inside
 385 \end{code}
 386
 387 %*********************************************************
 388 %*                                                      *
 389 \subsection{Stand-alone deriving declarations}
 390 %*                                                      *
 391 %*********************************************************
 392
 393 \begin{code}
 394 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
 395 rnSrcDerivDecl (DerivDecl ty)
 396   = do ty' <- rnLHsType (text "a deriving decl") ty
 397        let fvs = extractHsTyNames ty'
 398        return (DerivDecl ty', fvs)
 399 \end{code}
 400
 401 %*********************************************************
 402 %*                                                      *
 403 \subsection{Rules}
 404 %*                                                      *
 405 %*********************************************************
 406
 407 \begin{code}
 408 rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
 409   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
 410
 411     bindLocatedLocalsFV doc (map get_var vars)          $ \ ids ->
 412     mapFvRn rn_var (vars `zip` ids)             `thenM` \ (vars', fv_vars) ->
 413
 414     rnLExpr lhs                                 `thenM` \ (lhs', fv_lhs') ->
 415     rnLExpr rhs                                 `thenM` \ (rhs', fv_rhs') ->
 416
 417     checkValidRule rule_name ids lhs' fv_lhs'   `thenM_`
 418
 419     returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
 420              fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
 421   where
 422     doc = text "In the transformation rule" <+> ftext rule_name
 423
 424     get_var (RuleBndr v)      = v
 425     get_var (RuleBndrSig v _) = v
 426
 427     rn_var (RuleBndr (L loc v), id)
 428         = returnM (RuleBndr (L loc id), emptyFVs)
 429     rn_var (RuleBndrSig (L loc v) t, id)
 430         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
 431           returnM (RuleBndrSig (L loc id) t', fvs)
 432
 433 badRuleVar name var
 434   = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
 435          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 436                 ptext SLIT("does not appear on left hand side")]
 437 \end{code}
 438
 439 Note [Rule LHS validity checking]
 440 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 441 Check the shape of a transformation rule LHS.  Currently we only allow
 442 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
 443 @forall@'d variables.
 444
 445 We used restrict the form of the 'ei' to prevent you writing rules
 446 with LHSs with a complicated desugaring (and hence unlikely to match);
 447 (e.g. a case expression is not allowed: too elaborate.)
 448
 449 But there are legitimate non-trivial args ei, like sections and
 450 lambdas.  So it seems simmpler not to check at all, and that is why
 451 check_e is commented out.
 452
 453 \begin{code}
 454 checkValidRule rule_name ids lhs' fv_lhs'
 455   = do  {       -- Check for the form of the LHS
 456           case (validRuleLhs ids lhs') of
 457                 Nothing  -> return ()
 458                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
 459
 460                 -- Check that LHS vars are all bound
 461         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
 462         ; mappM (addErr . badRuleVar rule_name) bad_vars }
 463
 464 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 465 -- Nothing => OK
 466 -- Just e  => Not ok, and e is the offending expression
 467 validRuleLhs foralls lhs
 468   = checkl lhs
 469   where
 470     checkl (L loc e) = check e
 471
 472     check (OpApp e1 op _ e2)              = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
 473     check (HsApp e1 e2)                   = checkl e1 `seqMaybe` checkl_e e2
 474     check (HsVar v) | v `notElem` foralls = Nothing
 475     check other                           = Just other  -- Failure
 476
 477         -- Check an argument
 478     checkl_e (L loc e) = Nothing        -- Was (check_e e); see Note [Rule LHS validity checking]
 479
 480 {-      Commented out; see Note [Rule LHS validity checking] above
 481     check_e (HsVar v)     = Nothing
 482     check_e (HsPar e)     = checkl_e e
 483     check_e (HsLit e)     = Nothing
 484     check_e (HsOverLit e) = Nothing
 485
 486     check_e (OpApp e1 op _ e2)   = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
 487     check_e (HsApp e1 e2)        = checkl_e e1 `seqMaybe` checkl_e e2
 488     check_e (NegApp e _)         = checkl_e e
 489     check_e (ExplicitList _ es)  = checkl_es es
 490     check_e (ExplicitTuple es _) = checkl_es es
 491     check_e other                = Just other   -- Fails
 492
 493     checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
 494 -}
 495
 496 badRuleLhsErr name lhs bad_e
 497   = sep [ptext SLIT("Rule") <+> ftext name <> colon,
 498          nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
 499                        ptext SLIT("in left-hand side:") <+> ppr lhs])]
 500     $$
 501     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 502 \end{code}
 503
 504
 505 %*********************************************************
 506 %*                                                      *
 507 \subsection{Type, class and iface sig declarations}
 508 %*                                                      *
 509 %*********************************************************
 510
 511 @rnTyDecl@ uses the `global name function' to create a new type
 512 declaration in which local names have been replaced by their original
 513 names, reporting any unknown names.
 514
 515 Renaming type variables is a pain. Because they now contain uniques,
 516 it is necessary to pass in an association list which maps a parsed
 517 tyvar to its @Name@ representation.
 518 In some cases (type signatures of values),
 519 it is even necessary to go over the type first
 520 in order to get the set of tyvars used by it, make an assoc list,
 521 and then go over it again to rename the tyvars!
 522 However, we can also do some scoping checks at the same time.
 523
 524 \begin{code}
 525 rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
 526   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 527     returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
 528              emptyFVs)
 529
 530 -- all flavours of type family declarations ("type family", "newtype fanily",
 531 -- and "data family")
 532 rnTyClDecl (tydecl@TyFamily {}) =
 533   rnFamily tydecl bindTyVarsRn
 534
 535 -- "data", "newtype", "data instance, and "newtype instance" declarations
 536 rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 537                            tcdLName = tycon, tcdTyVars = tyvars,
 538                            tcdTyPats = typatsMaybe, tcdCons = condecls,
 539                            tcdKindSig = sig, tcdDerivs = derivs})
 540   | is_vanilla            -- Normal Haskell data type decl
 541   = ASSERT( isNothing sig )     -- In normal H98 form, kind signature on the
 542                                 -- data type is syntactically illegal
 543     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 544     do  { tycon' <- if isFamInstDecl tydecl
 545                     then lookupLocatedOccRn     tycon -- may be imported family
 546                     else lookupLocatedTopBndrRn tycon
 547         ; context' <- rnContext data_doc context
 548         ; typats' <- rnTyPats data_doc typatsMaybe
 549         ; (derivs', deriv_fvs) <- rn_derivs derivs
 550         ; checkDupNames data_doc con_names
 551         ; condecls' <- rnConDecls (unLoc tycon') condecls
 552         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context',
 553                            tcdLName = tycon', tcdTyVars = tyvars',
 554                            tcdTyPats = typats', tcdKindSig = Nothing,
 555                            tcdCons = condecls', tcdDerivs = derivs'},
 556                    delFVs (map hsLTyVarName tyvars')    $
 557                    extractHsCtxtTyNames context'        `plusFV`
 558                    plusFVs (map conDeclFVs condecls')   `plusFV`
 559                    deriv_fvs                            `plusFV`
 560                    (if isFamInstDecl tydecl
 561                    then unitFV (unLoc tycon')   -- type instance => use
 562                    else emptyFVs))
 563         }
 564
 565   | otherwise             -- GADT
 566   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
 567     do  { tycon' <- if isFamInstDecl tydecl
 568                     then lookupLocatedOccRn     tycon -- may be imported family
 569                     else lookupLocatedTopBndrRn tycon
 570         ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
 571         ; tyvars' <- bindTyVarsRn data_doc tyvars
 572                                   (\ tyvars' -> return tyvars')
 573                 -- For GADTs, the type variables in the declaration
 574                 -- do not scope over the constructor signatures
 575                 --      data T a where { T1 :: forall b. b-> b }
 576         ; (derivs', deriv_fvs) <- rn_derivs derivs
 577         ; checkDupNames data_doc con_names
 578         ; condecls' <- rnConDecls (unLoc tycon') condecls
 579         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
 580                            tcdLName = tycon', tcdTyVars = tyvars',
 581                            tcdTyPats = Nothing, tcdKindSig = sig,
 582                            tcdCons = condecls', tcdDerivs = derivs'},
 583                    plusFVs (map conDeclFVs condecls') `plusFV`
 584                    deriv_fvs                          `plusFV`
 585                    (if isFamInstDecl tydecl
 586                    then unitFV (unLoc tycon')   -- type instance => use
 587                    else emptyFVs))
 588         }
 589   where
 590     is_vanilla = case condecls of       -- Yuk
 591                      []                    -> True
 592                      L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
 593                      other                 -> False
 594
 595     none Nothing   = True
 596     none (Just []) = True
 597     none _         = False
 598
 599     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 600     con_names = map con_names_helper condecls
 601
 602     con_names_helper (L _ c) = con_name c
 603
 604     rn_derivs Nothing   = returnM (Nothing, emptyFVs)
 605     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 606                           returnM (Just ds', extractHsTyNames_s ds')
 607
 608 -- "type" and "type instance" declarations
 609 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
 610                               tcdTyPats = typatsMaybe, tcdSynRhs = ty})
 611   = bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 612     do { name' <- if isFamInstDecl tydecl
 613                   then lookupLocatedOccRn     name -- may be imported family
 614                   else lookupLocatedTopBndrRn name
 615        ; typats' <- rnTyPats syn_doc typatsMaybe
 616        ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
 617        ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
 618                              tcdTyPats = typats', tcdSynRhs = ty'},
 619                   delFVs (map hsLTyVarName tyvars') $
 620                   fvs                         `plusFV`
 621                    (if isFamInstDecl tydecl
 622                    then unitFV (unLoc name')    -- type instance => use
 623                    else emptyFVs))
 624        }
 625   where
 626     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 627
 628 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 629                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 630                        tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
 631   = do  { cname' <- lookupLocatedTopBndrRn cname
 632
 633         -- Tyvars scope over superclass context and method signatures
 634         ; (tyvars', context', fds', ats', ats_fvs, sigs')
 635             <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
 636              { context' <- rnContext cls_doc context
 637              ; fds' <- rnFds cls_doc fds
 638              ; (ats', ats_fvs) <- rnATs ats
 639              ; sigs' <- renameSigs okClsDclSig sigs
 640              ; return   (tyvars', context', fds', ats', ats_fvs, sigs') }
 641
 642         -- Check for duplicates among the associated types
 643         ; let at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats]
 644         ; checkDupNames at_doc at_rdr_names_w_locs
 645
 646         -- Check the signatures
 647         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 648         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
 649         ; checkDupNames sig_doc sig_rdr_names_w_locs
 650                 -- Typechecker is responsible for checking that we only
 651                 -- give default-method bindings for things in this class.
 652                 -- The renamer *could* check this for class decls, but can't
 653                 -- for instance decls.
 654
 655         -- The newLocals call is tiresome: given a generic class decl
 656         --      class C a where
 657         --        op :: a -> a
 658         --        op {| x+y |} (Inl a) = ...
 659         --        op {| x+y |} (Inr b) = ...
 660         --        op {| a*b |} (a*b)   = ...
 661         -- we want to name both "x" tyvars with the same unique, so that they are
 662         -- easy to group together in the typechecker.
 663         ; (mbinds', meth_fvs)
 664             <- extendTyVarEnvForMethodBinds tyvars' $ do
 665             { name_env <- getLocalRdrEnv
 666             ; let meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
 667                   gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
 668                                                  not (unLoc tv `elemLocalRdrEnv` name_env) ]
 669             ; checkDupNames meth_doc meth_rdr_names_w_locs
 670             ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
 671             ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
 672
 673   -- Haddock docs
 674         ; docs' <- mapM (wrapLocM rnDocDecl) docs
 675
 676         ; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
 677                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
 678                               tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
 679
 680                   delFVs (map hsLTyVarName tyvars')     $
 681                   extractHsCtxtTyNames context'         `plusFV`
 682                   plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
 683                   hsSigsFVs sigs'                       `plusFV`
 684                   meth_fvs                              `plusFV`
 685                   ats_fvs) }
 686   where
 687     meth_doc = text "In the default-methods for class"  <+> ppr cname
 688     cls_doc  = text "In the declaration for class"      <+> ppr cname
 689     sig_doc  = text "In the signatures for class"       <+> ppr cname
 690     at_doc   = text "In the associated types for class" <+> ppr cname
 691
 692 badGadtStupidTheta tycon
 693   = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
 694           ptext SLIT("(You can put a context on each contructor, though.)")]
 695 \end{code}
 696
 697 %*********************************************************
 698 %*                                                      *
 699 \subsection{Support code for type/data declarations}
 700 %*                                                      *
 701 %*********************************************************
 702
 703 \begin{code}
 704 -- Although, we are processing type patterns here, all type variables will
 705 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 706 -- type declaration to which these patterns belong)
 707 --
 708 rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
 709 rnTyPats _   Nothing       = return Nothing
 710 rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
 711
 712 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 713 rnConDecls tycon condecls
 714   = mappM (wrapLocM rnConDecl) condecls
 715
 716 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 717 rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc)
 718   = do  { addLocM checkConName name
 719
 720         ; new_name <- lookupLocatedTopBndrRn name
 721         ; name_env <- getLocalRdrEnv
 722
 723         -- For H98 syntax, the tvs are the existential ones
 724         -- For GADT syntax, the tvs are all the quantified tyvars
 725         -- Hence the 'filter' in the ResTyH98 case only
 726         ; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
 727               arg_tys       = hsConArgs details
 728               implicit_tvs  = case res_ty of
 729                                 ResTyH98 -> filter not_in_scope $
 730                                                 get_rdr_tvs arg_tys
 731                                 ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 732               tvs' = case expl of
 733                         Explicit -> tvs
 734                         Implicit -> userHsTyVarBndrs implicit_tvs
 735
 736         ; mb_doc' <- rnMbLHsDoc mb_doc
 737
 738         ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
 739         { new_context <- rnContext doc cxt
 740         ; new_details <- rnConDetails doc details
 741         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
 742         ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }}
 743  where
 744     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 745     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 746
 747 rnConResult _ details ResTyH98 = return (details, ResTyH98)
 748
 749 rnConResult doc details (ResTyGADT ty) = do
 750     ty' <- rnHsSigType doc ty
 751     let (arg_tys, res_ty) = splitHsFunType ty'
 752         -- We can split it up, now the renamer has dealt with fixities
 753     case details of
 754         PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
 755         RecCon fields -> return (details, ResTyGADT ty')
 756         InfixCon {}   -> panic "rnConResult"
 757
 758 rnConDetails doc (PrefixCon tys)
 759   = mappM (rnLHsType doc) tys   `thenM` \ new_tys  ->
 760     returnM (PrefixCon new_tys)
 761
 762 rnConDetails doc (InfixCon ty1 ty2)
 763   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 764     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 765     returnM (InfixCon new_ty1 new_ty2)
 766
 767 rnConDetails doc (RecCon fields)
 768   = checkDupNames doc field_names       `thenM_`
 769     mappM (rnField doc) fields          `thenM` \ new_fields ->
 770     returnM (RecCon new_fields)
 771   where
 772     field_names = [ name | HsRecField name _ _ <- fields ]
 773
 774 -- Document comments are renamed to Nothing here
 775 rnField doc (HsRecField name ty haddock_doc)
 776   = lookupLocatedTopBndrRn name `thenM` \ new_name ->
 777     rnLHsType doc ty            `thenM` \ new_ty ->
 778     rnMbLHsDoc haddock_doc      `thenM` \ new_haddock_doc ->
 779     returnM (HsRecField new_name new_ty new_haddock_doc)
 780
 781 -- Rename family declarations
 782 --
 783 -- * This function is parametrised by the routine handling the index
 784 --   variables.  On the toplevel, these are defining occurences, whereas they
 785 --   are usage occurences for associated types.
 786 --
 787 rnFamily :: TyClDecl RdrName
 788          -> (SDoc -> [LHsTyVarBndr RdrName] ->
 789              ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 790              RnM (TyClDecl Name, FreeVars))
 791          -> RnM (TyClDecl Name, FreeVars)
 792
 793 rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
 794                            tcdLName = tycon, tcdTyVars = tyvars})
 795         bindIdxVars =
 796       do { checkM (isDataFlavour flavour                      -- for synonyms,
 797                    || not (null tyvars)) $ addErr needOneIdx  -- #indexes >= 1
 798          ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
 799          ; tycon' <- lookupLocatedTopBndrRn tycon
 800          ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
 801                               tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
 802                     emptyFVs)
 803          } }
 804       where
 805         isDataFlavour (DataFamily _) = True
 806         isDataFlavour _              = False
 807
 808 family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
 809 needOneIdx = text "Type family declarations requires at least one type index"
 810
 811 -- Rename associated type declarations (in classes)
 812 --
 813 -- * This can be family declarations and (default) type instances
 814 --
 815 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 816 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 817   where
 818     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
 819     rn_at (tydecl@TySynonym {}) =
 820       do
 821         checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
 822         rnTyClDecl tydecl
 823     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 824
 825     lookupIdxVars _ tyvars cont =
 826       do { checkForDups tyvars;
 827          ; tyvars' <- mappM lookupIdxVar tyvars
 828          ; cont tyvars'
 829          }
 830     -- Type index variables must be class parameters, which are the only
 831     -- type variables in scope at this point.
 832     lookupIdxVar (L l tyvar) =
 833       do
 834         name' <- lookupOccRn (hsTyVarName tyvar)
 835         return $ L l (replaceTyVarName tyvar name')
 836
 837     -- Type variable may only occur once.
 838     --
 839     checkForDups [] = return ()
 840     checkForDups (L loc tv:ltvs) =
 841       do { setSrcSpan loc $
 842              when (hsTyVarName tv `ltvElem` ltvs) $
 843                addErr (repeatedTyVar tv)
 844          ; checkForDups ltvs
 845          }
 846
 847     rdrName `ltvElem` [] = False
 848     rdrName `ltvElem` (L _ tv:ltvs)
 849       | rdrName == hsTyVarName tv = True
 850       | otherwise                 = rdrName `ltvElem` ltvs
 851
 852 noPatterns = text "Default definition for an associated synonym cannot have"
 853              <+> text "type pattern"
 854
 855 repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+>
 856                    quotes (ppr tv)
 857
 858 -- This data decl will parse OK
 859 --      data T = a Int
 860 -- treating "a" as the constructor.
 861 -- It is really hard to make the parser spot this malformation.
 862 -- So the renamer has to check that the constructor is legal
 863 --
 864 -- We can get an operator as the constructor, even in the prefix form:
 865 --      data T = :% Int Int
 866 -- from interface files, which always print in prefix form
 867
 868 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
 869
 870 badDataCon name
 871    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 872 \end{code}
 873
 874
 875 %*********************************************************
 876 %*                                                      *
 877 \subsection{Support code to rename types}
 878 %*                                                      *
 879 %*********************************************************
 880
 881 \begin{code}
 882 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
 883
 884 rnFds doc fds
 885   = mappM (wrapLocM rn_fds) fds
 886   where
 887     rn_fds (tys1, tys2)
 888       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
 889         rnHsTyVars doc tys2             `thenM` \ tys2' ->
 890         returnM (tys1', tys2')
 891
 892 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 893 rnHsTyvar doc tyvar = lookupOccRn tyvar
 894 \end{code}
 895
 896
 897 %*********************************************************
 898 %*                                                      *
 899                 Splices
 900 %*                                                      *
 901 %*********************************************************
 902
 903 Note [Splices]
 904 ~~~~~~~~~~~~~~
 905 Consider
 906         f = ...
 907         h = ...$(thing "f")...
 908
 909 The splice can expand into literally anything, so when we do dependency
 910 analysis we must assume that it might mention 'f'.  So we simply treat
 911 all locally-defined names as mentioned by any splice.  This is terribly
 912 brutal, but I don't see what else to do.  For example, it'll mean
 913 that every locally-defined thing will appear to be used, so no unused-binding
 914 warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
 915 and that will crash the type checker because 'f' isn't in scope.
 916
 917 Currently, I'm not treating a splice as also mentioning every import,
 918 which is a bit inconsistent -- but there are a lot of them.  We might
 919 thereby get some bogus unused-import warnings, but we won't crash the
 920 type checker.  Not very satisfactory really.
 921
 922 \begin{code}
 923 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
 924 rnSplice (HsSplice n expr)
 925   = do  { checkTH expr "splice"
 926         ; loc  <- getSrcSpanM
 927         ; [n'] <- newLocalsRn [L loc n]
 928         ; (expr', fvs) <- rnLExpr expr
 929
 930         -- Ugh!  See Note [Splices] above
 931         ; lcl_rdr <- getLocalRdrEnv
 932         ; gbl_rdr <- getGlobalRdrEnv
 933         ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
 934                                                     isLocalGRE gre]
 935               lcl_names = mkNameSet (occEnvElts lcl_rdr)
 936
 937         ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
 938
 939 #ifdef GHCI
 940 checkTH e what = returnM ()     -- OK
 941 #else
 942 checkTH e what  -- Raise an error in a stage-1 compiler
 943   = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
 944                   ptext SLIT("illegal in a stage-1 compiler"),
 945                   nest 2 (ppr e)])
 946 #endif
 947 \end{code}