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