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