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