compiler/rename/RnSource.lhs

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