ghc/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 import RdrHsSyn         ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
  20 import RnHsSyn
  21 import RnTypes          ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
  22 import RnBinds          ( rnTopBinds, rnMethodBinds, renameSigs )
  23 import RnEnv            ( lookupLocalDataTcNames,
  24                           lookupLocatedTopBndrRn, lookupLocatedOccRn,
  25                           lookupOccRn, newLocalsRn,
  26                           bindLocatedLocalsFV, bindPatSigTyVarsFV,
  27                           bindTyVarsRn, extendTyVarEnvFVRn,
  28                           bindLocalNames, checkDupNames, mapFvRn
  29                         )
  30 import TcRnMonad
  31
  32 import HscTypes         ( FixityEnv, FixItem(..),
  33                           Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
  34 import Class            ( FunDep )
  35 import Name             ( Name, nameOccName )
  36 import NameSet
  37 import NameEnv
  38 import Outputable
  39 import SrcLoc           ( Located(..), unLoc, getLoc, noLoc )
  40 import DynFlags ( DynFlag(..) )
  41 import Maybes           ( seqMaybe )
  42 import Maybe            ( isNothing )
  43 import BasicTypes       ( Boxity(..) )
  44 \end{code}
  45
  46 @rnSourceDecl@ `renames' declarations.
  47 It simultaneously performs dependency analysis and precedence parsing.
  48 It also does the following error checks:
  49 \begin{enumerate}
  50 \item
  51 Checks that tyvars are used properly. This includes checking
  52 for undefined tyvars, and tyvars in contexts that are ambiguous.
  53 (Some of this checking has now been moved to module @TcMonoType@,
  54 since we don't have functional dependency information at this point.)
  55 \item
  56 Checks that all variable occurences are defined.
  57 \item
  58 Checks the @(..)@ etc constraints in the export list.
  59 \end{enumerate}
  60
  61
  62 \begin{code}
  63 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
  64
  65 rnSrcDecls (HsGroup { hs_valds  = val_decls,
  66                       hs_tyclds = tycl_decls,
  67                       hs_instds = inst_decls,
  68                       hs_fixds  = fix_decls,
  69                       hs_depds  = deprec_decls,
  70                       hs_fords  = foreign_decls,
  71                       hs_defds  = default_decls,
  72                       hs_ruleds = rule_decls })
  73
  74  = do {         -- Deal with deprecations (returns only the extra deprecations)
  75         deprecs <- rnSrcDeprecDecls deprec_decls ;
  76         updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
  77                   $ do {
  78
  79                 -- Deal with top-level fixity decls
  80                 -- (returns the total new fixity env)
  81         fix_env <- rnSrcFixityDecls fix_decls ;
  82         updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
  83                   $ do {
  84
  85                 -- Rename other declarations
  86         traceRn (text "Start rnmono") ;
  87         (rn_val_decls, bind_dus) <- rnTopBinds val_decls ;
  88         traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
  89
  90                 -- You might think that we could build proper def/use information
  91                 -- for type and class declarations, but they can be involved
  92                 -- in mutual recursion across modules, and we only do the SCC
  93                 -- analysis for them in the type checker.
  94                 -- So we content ourselves with gathering uses only; that
  95                 -- means we'll only report a declaration as unused if it isn't
  96                 -- mentioned at all.  Ah well.
  97         (rn_tycl_decls,    src_fvs1)
  98            <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
  99         (rn_inst_decls,    src_fvs2)
 100            <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
 101         (rn_rule_decls,    src_fvs3)
 102            <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
 103         (rn_foreign_decls, src_fvs4)
 104            <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
 105         (rn_default_decls, src_fvs5)
 106            <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
 107
 108         let {
 109            rn_group = HsGroup { hs_valds  = rn_val_decls,
 110                                 hs_tyclds = rn_tycl_decls,
 111                                 hs_instds = rn_inst_decls,
 112                                 hs_fixds  = [],
 113                                 hs_depds  = [],
 114                                 hs_fords  = rn_foreign_decls,
 115                                 hs_defds  = rn_default_decls,
 116                                 hs_ruleds = rn_rule_decls } ;
 117
 118            other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3,
 119                                 src_fvs4, src_fvs5] ;
 120            src_dus = bind_dus `plusDU` usesOnly other_fvs
 121                 -- Note: src_dus will contain *uses* for locally-defined types
 122                 -- and classes, but no *defs* for them.  (Because rnTyClDecl
 123                 -- returns only the uses.)  This is a little
 124                 -- surprising but it doesn't actually matter at all.
 125         } ;
 126
 127         traceRn (text "finish rnSrc" <+> ppr rn_group) ;
 128         traceRn (text "finish Dus" <+> ppr src_dus ) ;
 129         tcg_env <- getGblEnv ;
 130         return (tcg_env `addTcgDUs` src_dus, rn_group)
 131     }}}
 132
 133 rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
 134 rnTyClDecls tycl_decls = do
 135   (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
 136   return decls'
 137
 138 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
 139 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
 140 \end{code}
 141
 142
 143 %*********************************************************
 144 %*                                                       *
 145         Source-code fixity declarations
 146 %*                                                       *
 147 %*********************************************************
 148
 149 \begin{code}
 150 rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM FixityEnv
 151 rnSrcFixityDecls fix_decls
 152   = getGblEnv                                   `thenM` \ gbl_env ->
 153     foldlM rnFixityDecl (tcg_fix_env gbl_env)
 154             fix_decls                                   `thenM` \ fix_env ->
 155     traceRn (text "fixity env" <+> pprFixEnv fix_env)   `thenM_`
 156     returnM fix_env
 157
 158 rnFixityDecl :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv
 159 rnFixityDecl fix_env (L loc (FixitySig rdr_name fixity))
 160   = setSrcSpan loc $
 161         -- GHC extension: look up both the tycon and data con
 162         -- for con-like things
 163         -- If neither are in scope, report an error; otherwise
 164         -- add both to the fixity env
 165      addLocM lookupLocalDataTcNames rdr_name    `thenM` \ names ->
 166      foldlM add fix_env names
 167   where
 168     add fix_env name
 169       = case lookupNameEnv fix_env name of
 170           Just (FixItem _ _ loc')
 171                   -> addLocErr rdr_name (dupFixityDecl loc')    `thenM_`
 172                      returnM fix_env
 173           Nothing -> returnM (extendNameEnv fix_env name fix_item)
 174       where
 175         fix_item = FixItem (nameOccName name) fixity (getLoc rdr_name)
 176
 177 pprFixEnv :: FixityEnv -> SDoc
 178 pprFixEnv env
 179   = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n)
 180                   (nameEnvElts env)
 181
 182 dupFixityDecl loc rdr_name
 183   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
 184           ptext SLIT("also at ") <+> ppr loc
 185         ]
 186 \end{code}
 187
 188
 189 %*********************************************************
 190 %*                                                       *
 191         Source-code deprecations declarations
 192 %*                                                       *
 193 %*********************************************************
 194
 195 For deprecations, all we do is check that the names are in scope.
 196 It's only imported deprecations, dealt with in RnIfaces, that we
 197 gather them together.
 198
 199 \begin{code}
 200 rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
 201 rnSrcDeprecDecls []
 202   = returnM NoDeprecs
 203
 204 rnSrcDeprecDecls decls
 205   = mappM (addLocM rn_deprec) decls     `thenM` \ pairs_s ->
 206     returnM (DeprecSome (mkNameEnv (concat pairs_s)))
 207  where
 208    rn_deprec (Deprecation rdr_name txt)
 209      = lookupLocalDataTcNames rdr_name  `thenM` \ names ->
 210        returnM [(name, (nameOccName name, txt)) | name <- names]
 211
 212 checkModDeprec :: Maybe DeprecTxt -> Deprecations
 213 -- Check for a module deprecation; done once at top level
 214 checkModDeprec Nothing    = NoDeprecs
 215 checkModDeprec (Just txt) = DeprecAll txt
 216 \end{code}
 217
 218 %*********************************************************
 219 %*                                                      *
 220 \subsection{Source code declarations}
 221 %*                                                      *
 222 %*********************************************************
 223
 224 \begin{code}
 225 rnDefaultDecl (DefaultDecl tys)
 226   = mapFvRn (rnHsTypeFVs doc_str) tys   `thenM` \ (tys', fvs) ->
 227     returnM (DefaultDecl tys', fvs)
 228   where
 229     doc_str = text "In a `default' declaration"
 230 \end{code}
 231
 232 %*********************************************************
 233 %*                                                      *
 234 \subsection{Foreign declarations}
 235 %*                                                      *
 236 %*********************************************************
 237
 238 \begin{code}
 239 rnHsForeignDecl (ForeignImport name ty spec isDeprec)
 240   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 241     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 242     returnM (ForeignImport name' ty' spec isDeprec, fvs)
 243
 244 rnHsForeignDecl (ForeignExport name ty spec isDeprec)
 245   = lookupLocatedOccRn name             `thenM` \ name' ->
 246     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 247     returnM (ForeignExport name' ty' spec isDeprec, fvs )
 248         -- NB: a foreign export is an *occurrence site* for name, so
 249         --     we add it to the free-variable list.  It might, for example,
 250         --     be imported from another module
 251
 252 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
 253 \end{code}
 254
 255
 256 %*********************************************************
 257 %*                                                      *
 258 \subsection{Instance declarations}
 259 %*                                                      *
 260 %*********************************************************
 261
 262 \begin{code}
 263 rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
 264         -- Used for both source and interface file decls
 265   = rnHsSigType (text "an instance decl") inst_ty       `thenM` \ inst_ty' ->
 266
 267         -- Rename the bindings
 268         -- The typechecker (not the renamer) checks that all
 269         -- the bindings are for the right class
 270     let
 271         meth_doc    = text "In the bindings in an instance declaration"
 272         meth_names  = collectHsBindLocatedBinders mbinds
 273         (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
 274     in
 275     checkDupNames meth_doc meth_names   `thenM_`
 276     extendTyVarEnvForMethodBinds inst_tyvars (
 277         -- (Slightly strangely) the forall-d tyvars scope over
 278         -- the method bindings too
 279         rnMethodBinds cls [] mbinds
 280     )                                           `thenM` \ (mbinds', meth_fvs) ->
 281         -- Rename the prags and signatures.
 282         -- Note that the type variables are not in scope here,
 283         -- so that      instance Eq a => Eq (T a) where
 284         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 285         -- works OK.
 286         --
 287         -- But the (unqualified) method names are in scope
 288     let
 289         binders = collectHsBindBinders mbinds'
 290         ok_sig  = okInstDclSig (mkNameSet binders)
 291     in
 292     bindLocalNames binders (renameSigs ok_sig uprags)   `thenM` \ uprags' ->
 293
 294     returnM (InstDecl inst_ty' mbinds' uprags',
 295              meth_fvs `plusFV` hsSigsFVs uprags'
 296                       `plusFV` extractHsTyNames inst_ty')
 297 \end{code}
 298
 299 For the method bindings in class and instance decls, we extend the
 300 type variable environment iff -fglasgow-exts
 301
 302 \begin{code}
 303 extendTyVarEnvForMethodBinds tyvars thing_inside
 304   = doptM Opt_GlasgowExts                       `thenM` \ opt_GlasgowExts ->
 305     if opt_GlasgowExts then
 306         extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
 307     else
 308         thing_inside
 309 \end{code}
 310
 311
 312 %*********************************************************
 313 %*                                                      *
 314 \subsection{Rules}
 315 %*                                                      *
 316 %*********************************************************
 317
 318 \begin{code}
 319 rnHsRuleDecl (HsRule rule_name act vars lhs rhs)
 320   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
 321
 322     bindLocatedLocalsFV doc (map get_var vars)          $ \ ids ->
 323     mapFvRn rn_var (vars `zip` ids)             `thenM` \ (vars', fv_vars) ->
 324
 325     rnLExpr lhs                                 `thenM` \ (lhs', fv_lhs) ->
 326     rnLExpr rhs                                 `thenM` \ (rhs', fv_rhs) ->
 327     let
 328         mb_bad = validRuleLhs ids lhs'
 329     in
 330     checkErr (isNothing mb_bad)
 331              (badRuleLhsErr rule_name lhs' mb_bad)      `thenM_`
 332     let
 333         bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
 334     in
 335     mappM (addErr . badRuleVar rule_name) bad_vars      `thenM_`
 336     returnM (HsRule rule_name act vars' lhs' rhs',
 337              fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
 338   where
 339     doc = text "In the transformation rule" <+> ftext rule_name
 340
 341     get_var (RuleBndr v)      = v
 342     get_var (RuleBndrSig v _) = v
 343
 344     rn_var (RuleBndr (L loc v), id)
 345         = returnM (RuleBndr (L loc id), emptyFVs)
 346     rn_var (RuleBndrSig (L loc v) t, id)
 347         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
 348           returnM (RuleBndrSig (L loc id) t', fvs)
 349 \end{code}
 350
 351 Check the shape of a transformation rule LHS.  Currently
 352 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 353 not one of the @forall@'d variables.  We also restrict the form of the LHS so
 354 that it may be plausibly matched.  Basically you only get to write ordinary
 355 applications.  (E.g. a case expression is not allowed: too elaborate.)
 356
 357 NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
 358
 359 \begin{code}
 360 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 361 -- Nothing => OK
 362 -- Just e  => Not ok, and e is the offending expression
 363 validRuleLhs foralls lhs
 364   = checkl lhs
 365   where
 366     checkl (L loc e) = check e
 367
 368     check (OpApp e1 op _ e2)              = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
 369     check (HsApp e1 e2)                   = checkl e1 `seqMaybe` checkl_e e2
 370     check (HsVar v) | v `notElem` foralls = Nothing
 371     check other                           = Just other  -- Failure
 372
 373     checkl_e (L loc e) = check_e e
 374
 375     check_e (HsVar v)     = Nothing
 376     check_e (HsPar e)     = checkl_e e
 377     check_e (HsLit e)     = Nothing
 378     check_e (HsOverLit e) = Nothing
 379
 380     check_e (OpApp e1 op _ e2)   = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
 381     check_e (HsApp e1 e2)        = checkl_e e1 `seqMaybe` checkl_e e2
 382     check_e (NegApp e _)         = checkl_e e
 383     check_e (ExplicitList _ es)  = checkl_es es
 384     check_e (ExplicitTuple es _) = checkl_es es
 385     check_e other                = Just other   -- Fails
 386
 387     checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
 388
 389 badRuleLhsErr name lhs (Just bad_e)
 390   = sep [ptext SLIT("Rule") <+> ftext name <> colon,
 391          nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
 392                        ptext SLIT("in left-hand side:") <+> ppr lhs])]
 393     $$
 394     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 395
 396 badRuleVar name var
 397   = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
 398          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 399                 ptext SLIT("does not appear on left hand side")]
 400 \end{code}
 401
 402
 403 %*********************************************************
 404 %*                                                      *
 405 \subsection{Type, class and iface sig declarations}
 406 %*                                                      *
 407 %*********************************************************
 408
 409 @rnTyDecl@ uses the `global name function' to create a new type
 410 declaration in which local names have been replaced by their original
 411 names, reporting any unknown names.
 412
 413 Renaming type variables is a pain. Because they now contain uniques,
 414 it is necessary to pass in an association list which maps a parsed
 415 tyvar to its @Name@ representation.
 416 In some cases (type signatures of values),
 417 it is even necessary to go over the type first
 418 in order to get the set of tyvars used by it, make an assoc list,
 419 and then go over it again to rename the tyvars!
 420 However, we can also do some scoping checks at the same time.
 421
 422 \begin{code}
 423 rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
 424   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 425     returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
 426              emptyFVs)
 427
 428 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
 429                     tcdTyVars = tyvars, tcdCons = condecls,
 430                     tcdKindSig = sig, tcdDerivs = derivs})
 431   | is_vanilla  -- Normal Haskell data type decl
 432   = ASSERT( isNothing sig )     -- In normal H98 form, kind signature on the
 433                                 -- data type is syntactically illegal
 434     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 435     do  { tycon' <- lookupLocatedTopBndrRn tycon
 436         ; context' <- rnContext data_doc context
 437         ; (derivs', deriv_fvs) <- rn_derivs derivs
 438         ; checkDupNames data_doc con_names
 439         ; condecls' <- rnConDecls (unLoc tycon') condecls
 440         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
 441                            tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls',
 442                            tcdDerivs = derivs'},
 443                    delFVs (map hsLTyVarName tyvars')    $
 444                    extractHsCtxtTyNames context'        `plusFV`
 445                    plusFVs (map conDeclFVs condecls') `plusFV`
 446                    deriv_fvs) }
 447
 448   | otherwise   -- GADT
 449   = do  { tycon' <- lookupLocatedTopBndrRn tycon
 450         ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
 451         ; tyvars' <- bindTyVarsRn data_doc tyvars
 452                                   (\ tyvars' -> return tyvars')
 453                 -- For GADTs, the type variables in the declaration
 454                 -- do not scope over the constructor signatures
 455                 --      data T a where { T1 :: forall b. b-> b }
 456         ; (derivs', deriv_fvs) <- rn_derivs derivs
 457         ; checkDupNames data_doc con_names
 458         ; condecls' <- rnConDecls (unLoc tycon') condecls
 459         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
 460                            tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
 461                            tcdDerivs = derivs'},
 462                    plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
 463
 464   where
 465     is_vanilla = case condecls of       -- Yuk
 466                      []                    -> True
 467                      L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
 468                      other                 -> False
 469
 470     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 471     con_names = map con_names_helper condecls
 472
 473     con_names_helper (L _ c) = con_name c
 474
 475     rn_derivs Nothing   = returnM (Nothing, emptyFVs)
 476     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 477                           returnM (Just ds', extractHsTyNames_s ds')
 478
 479 rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
 480   = lookupLocatedTopBndrRn name                 `thenM` \ name' ->
 481     bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 482     rnHsTypeFVs syn_doc ty                      `thenM` \ (ty', fvs) ->
 483     returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
 484                         tcdSynRhs = ty'},
 485              delFVs (map hsLTyVarName tyvars') fvs)
 486   where
 487     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 488
 489 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 490                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 491                        tcdMeths = mbinds})
 492   = lookupLocatedTopBndrRn cname                `thenM` \ cname' ->
 493
 494         -- Tyvars scope over superclass context and method signatures
 495     bindTyVarsRn cls_doc tyvars                 ( \ tyvars' ->
 496         rnContext cls_doc context       `thenM` \ context' ->
 497         rnFds cls_doc fds               `thenM` \ fds' ->
 498         renameSigs okClsDclSig sigs     `thenM` \ sigs' ->
 499         returnM   (tyvars', context', fds', sigs')
 500     )   `thenM` \ (tyvars', context', fds', sigs') ->
 501
 502         -- Check the signatures
 503         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 504     let
 505         sig_rdr_names_w_locs   = [op | L _ (Sig op _) <- sigs]
 506     in
 507     checkDupNames sig_doc sig_rdr_names_w_locs  `thenM_`
 508         -- Typechecker is responsible for checking that we only
 509         -- give default-method bindings for things in this class.
 510         -- The renamer *could* check this for class decls, but can't
 511         -- for instance decls.
 512
 513         -- The newLocals call is tiresome: given a generic class decl
 514         --      class C a where
 515         --        op :: a -> a
 516         --        op {| x+y |} (Inl a) = ...
 517         --        op {| x+y |} (Inr b) = ...
 518         --        op {| a*b |} (a*b)   = ...
 519         -- we want to name both "x" tyvars with the same unique, so that they are
 520         -- easy to group together in the typechecker.
 521     extendTyVarEnvForMethodBinds tyvars' (
 522          getLocalRdrEnv                                 `thenM` \ name_env ->
 523          let
 524              meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
 525              gen_rdr_tyvars_w_locs =
 526                 [ tv | tv <- extractGenericPatTyVars mbinds,
 527                       not (unLoc tv `elemLocalRdrEnv` name_env) ]
 528          in
 529          checkDupNames meth_doc meth_rdr_names_w_locs   `thenM_`
 530          newLocalsRn gen_rdr_tyvars_w_locs      `thenM` \ gen_tyvars ->
 531          rnMethodBinds (unLoc cname') gen_tyvars mbinds
 532     ) `thenM` \ (mbinds', meth_fvs) ->
 533
 534     returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
 535                          tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
 536              delFVs (map hsLTyVarName tyvars')  $
 537              extractHsCtxtTyNames context'          `plusFV`
 538              plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
 539              hsSigsFVs sigs'                        `plusFV`
 540              meth_fvs)
 541   where
 542     meth_doc = text "In the default-methods for class"  <+> ppr cname
 543     cls_doc  = text "In the declaration for class"      <+> ppr cname
 544     sig_doc  = text "In the signatures for class"       <+> ppr cname
 545
 546 badGadtStupidTheta tycon
 547   = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
 548           ptext SLIT("(You can put a context on each contructor, though.)")]
 549 \end{code}
 550
 551 %*********************************************************
 552 %*                                                      *
 553 \subsection{Support code for type/data declarations}
 554 %*                                                      *
 555 %*********************************************************
 556
 557 \begin{code}
 558 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 559 rnConDecls tycon condecls
 560   = mappM (wrapLocM rnConDecl) condecls
 561
 562 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 563 rnConDecl (ConDecl name expl tvs cxt details res_ty)
 564   = do  { addLocM checkConName name
 565
 566         ; new_name <- lookupLocatedTopBndrRn name
 567         ; name_env <- getLocalRdrEnv
 568
 569         -- For H98 syntax, the tvs are the existential ones
 570         -- For GADT syntax, the tvs are all the quantified tyvars
 571         -- Hence the 'filter' in the ResTyH98 case only
 572         ; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
 573               arg_tys       = hsConArgs details
 574               implicit_tvs  = case res_ty of
 575                                 ResTyH98 -> filter not_in_scope $
 576                                                 get_rdr_tvs arg_tys
 577                                 ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 578               tvs' = case expl of
 579                         Explicit -> tvs
 580                         Implicit -> userHsTyVarBndrs implicit_tvs
 581
 582         ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
 583         { new_context <- rnContext doc cxt
 584         ; new_details <- rnConDetails doc details
 585         ; new_res_ty  <- rnConResult doc res_ty
 586         ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty
 587         ; traceRn (text "****** - autrijus" <> ppr rv)
 588         ; return rv } }
 589   where
 590     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 591     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 592
 593 rnConResult _ ResTyH98 = return ResTyH98
 594 rnConResult doc (ResTyGADT ty) = do
 595     ty' <- rnHsSigType doc ty
 596     return $ ResTyGADT ty'
 597
 598 rnConDetails doc (PrefixCon tys)
 599   = mappM (rnLHsType doc) tys   `thenM` \ new_tys  ->
 600     returnM (PrefixCon new_tys)
 601
 602 rnConDetails doc (InfixCon ty1 ty2)
 603   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 604     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 605     returnM (InfixCon new_ty1 new_ty2)
 606
 607 rnConDetails doc (RecCon fields)
 608   = checkDupNames doc field_names       `thenM_`
 609     mappM (rnField doc) fields          `thenM` \ new_fields ->
 610     returnM (RecCon new_fields)
 611   where
 612     field_names = [fld | (fld, _) <- fields]
 613
 614 rnField doc (name, ty)
 615   = lookupLocatedTopBndrRn name `thenM` \ new_name ->
 616     rnLHsType doc ty            `thenM` \ new_ty ->
 617     returnM (new_name, new_ty)
 618
 619 -- This data decl will parse OK
 620 --      data T = a Int
 621 -- treating "a" as the constructor.
 622 -- It is really hard to make the parser spot this malformation.
 623 -- So the renamer has to check that the constructor is legal
 624 --
 625 -- We can get an operator as the constructor, even in the prefix form:
 626 --      data T = :% Int Int
 627 -- from interface files, which always print in prefix form
 628
 629 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
 630
 631 badDataCon name
 632    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 633 \end{code}
 634
 635
 636 %*********************************************************
 637 %*                                                      *
 638 \subsection{Support code to rename types}
 639 %*                                                      *
 640 %*********************************************************
 641
 642 \begin{code}
 643 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
 644
 645 rnFds doc fds
 646   = mappM (wrapLocM rn_fds) fds
 647   where
 648     rn_fds (tys1, tys2)
 649       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
 650         rnHsTyVars doc tys2             `thenM` \ tys2' ->
 651         returnM (tys1', tys2')
 652
 653 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 654 rnHsTyvar doc tyvar = lookupOccRn tyvar
 655 \end{code}
 656
 657
 658 %*********************************************************
 659 %*                                                      *
 660                 Splices
 661 %*                                                      *
 662 %*********************************************************
 663
 664 \begin{code}
 665 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
 666 rnSplice (HsSplice n expr)
 667   = checkTH expr "splice"       `thenM_`
 668     getSrcSpanM                 `thenM` \ loc ->
 669     newLocalsRn [L loc n]       `thenM` \ [n'] ->
 670     rnLExpr expr                `thenM` \ (expr', fvs) ->
 671     returnM (HsSplice n' expr', fvs)
 672
 673 #ifdef GHCI
 674 checkTH e what = returnM ()     -- OK
 675 #else
 676 checkTH e what  -- Raise an error in a stage-1 compiler
 677   = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
 678                   ptext SLIT("illegal in a stage-1 compiler"),
 679                   nest 2 (ppr e)])
 680 #endif
 681 \end{code}