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