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