RnSource.hs 68.3 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

4
\section[RnSource]{Main pass of renamer}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7 8
{-# LANGUAGE CPP, ScopedTypeVariables #-}

9
module RnSource (
10
        rnSrcDecls, addTcgDUs, findSplice
11
    ) where
12

13
#include "HsVersions.h"
sof's avatar
sof committed
14

15
import {-# SOURCE #-} RnExpr( rnLExpr )
16
import {-# SOURCE #-} RnSplice ( rnSpliceDecl )
17

18
import HsSyn
19
import RdrName
20
import RnTypes
21
import RnBinds
22
import RnEnv
23
import RnNames
24
import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
25
import TcAnnotations    ( annCtxt )
26
import TcRnMonad
27

28
import ForeignCall      ( CCallTarget(..) )
29
import Module
30 31
import HscTypes         ( Warnings(..), plusWarns )
import Class            ( FunDep )
32
import PrelNames        ( isUnboundName )
33
import Name
34
import NameSet
35
import NameEnv
36
import Avail
37
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
38
import Bag
39
import BasicTypes       ( RuleName )
40
import FastString
41
import SrcLoc
42
import DynFlags
43
import HscTypes         ( HscEnv, hsc_dflags )
44
import ListSetOps       ( findDupsEq, removeDups )
45
import Digraph          ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
46

47
import Control.Monad
48
import Data.List( partition, sortBy )
49
import Maybes( orElse, mapMaybe )
50
#if __GLASGOW_HASKELL__ < 709
51
import Data.Traversable (traverse)
52
#endif
53

Austin Seipp's avatar
Austin Seipp committed
54
{-
55
@rnSourceDecl@ `renames' declarations.
56 57 58 59 60 61
It simultaneously performs dependency analysis and precedence parsing.
It also does the following error checks:
\begin{enumerate}
\item
Checks that tyvars are used properly. This includes checking
for undefined tyvars, and tyvars in contexts that are ambiguous.
62 63
(Some of this checking has now been moved to module @TcMonoType@,
since we don't have functional dependency information at this point.)
64
\item
Gabor Greif's avatar
Gabor Greif committed
65
Checks that all variable occurrences are defined.
66
\item
67
Checks the @(..)@ etc constraints in the export list.
68
\end{enumerate}
Austin Seipp's avatar
Austin Seipp committed
69
-}
70

71
-- Brings the binders of the group into scope in the appropriate places;
72
-- does NOT assume that anything is in scope already
Simon Peyton Jones's avatar
Simon Peyton Jones committed
73
rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
74
-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
Simon Peyton Jones's avatar
Simon Peyton Jones committed
75 76 77 78 79 80 81 82 83 84 85 86 87
rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                            hs_splcds  = splice_decls,
                            hs_tyclds  = tycl_decls,
                            hs_instds  = inst_decls,
                            hs_derivds = deriv_decls,
                            hs_fixds   = fix_decls,
                            hs_warnds  = warn_decls,
                            hs_annds   = ann_decls,
                            hs_fords   = foreign_decls,
                            hs_defds   = default_decls,
                            hs_ruleds  = rule_decls,
                            hs_vects   = vect_decls,
                            hs_docs    = docs })
88 89 90
 = do {
   -- (A) Process the fixity declarations, creating a mapping from
   --     FastStrings to FixItems.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
91
   --     Also checks for duplicates.
92
   local_fix_env <- makeMiniFixityEnv fix_decls ;
93 94

   -- (B) Bring top level binders (and their fixities) into scope,
95 96 97 98 99 100 101 102 103 104
   --     *except* for the value bindings, which get done in step (D)
   --     with collectHsIdBinders. However *do* include
   --
   --        * Class ops, data constructors, and record fields,
   --          because they do not have value declarations.
   --          Aso step (C) depends on datacons and record fields
   --
   --        * For hs-boot files, include the value signatures
   --          Again, they have no value declarations
   --
105
   (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
106
   setEnvs tc_envs $ do {
107 108 109 110 111 112 113

   failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations

   -- (C) Extract the mapping from data constructors to field names and
   --     extend the record field env.
   --     This depends on the data constructors and field names being in
   --     scope from (B) above
114
   inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
115

116 117 118 119 120 121 122 123
   -- (D1) Bring pattern synonyms into scope.
   --      Need to do this before (D2) because rnTopBindsLHS
   --      looks up those pattern synonyms (Trac #9889)
   pat_syn_bndrs <- mapM newTopSrcBinder (hsPatSynBinders val_decls) ;
   tc_envs <- extendGlobalRdrEnvRn (map Avail pat_syn_bndrs) local_fix_env ;
   setEnvs tc_envs $ do {

   -- (D2) Rename the left-hand sides of the value bindings.
124 125 126 127
   --     This depends on everything from (B) being in scope,
   --     and on (C) for resolving record wild cards.
   --     It uses the fixity env from (A) to bind fixities for view patterns.
   new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
128 129 130 131 132 133 134

   -- Bind the LHSes (and their fixities) in the global rdr environment
   let { id_bndrs = collectHsIdBinders new_lhs } ;  -- Excludes pattern-synonym binders
                                                    -- They are already in scope
   traceRn (text "rnSrcDecls" <+> ppr id_bndrs) ;
   tc_envs <- extendGlobalRdrEnvRn (map Avail id_bndrs) local_fix_env ;
   setEnvs tc_envs $ do {
135 136 137 138 139 140 141 142 143 144 145 146 147 148

   --  Now everything is in scope, as the remaining renaming assumes.

   -- (E) Rename type and class decls
   --     (note that value LHSes need to be in scope for default methods)
   --
   -- You might think that we could build proper def/use information
   -- for type and class declarations, but they can be involved
   -- in mutual recursion across modules, and we only do the SCC
   -- analysis for them in the type checker.
   -- So we content ourselves with gathering uses only; that
   -- means we'll only report a declaration as unused if it isn't
   -- mentioned at all.  Ah well.
   traceRn (text "Start rnTyClDecls") ;
Simon Peyton Jones's avatar
Simon Peyton Jones committed
149
   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
150 151 152

   -- (F) Rename Value declarations right-hand sides
   traceRn (text "Start rnmono") ;
153 154
   let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
   (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ;
155 156 157
   traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;

   -- (G) Rename Fixity and deprecations
158

159
   -- Rename fixity declarations and error if we try to
160
   -- fix something from another module (duplicates were checked in (A))
161
   let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
162
   rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
163 164

   -- Rename deprec decls;
165 166
   -- check for duplicates and ensure that deprecated things are defined locally
   -- at the moment, we don't keep these around past renaming
167
   rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
168 169 170 171

   -- (H) Rename Everything else

   (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
172
   (rn_rule_decls,    src_fvs3) <- setXOptM Opt_ScopedTypeVariables $
Alan Zimmerman's avatar
Alan Zimmerman committed
173
                                   rnList rnHsRuleDecls rule_decls ;
174 175 176 177 178 179
                           -- Inside RULES, scoped type variables are on
   (rn_vect_decls,    src_fvs4) <- rnList rnHsVectDecl    vect_decls ;
   (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ;
   (rn_ann_decls,     src_fvs6) <- rnList rnAnnDecl       ann_decls ;
   (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl   default_decls ;
   (rn_deriv_decls,   src_fvs8) <- rnList rnSrcDerivDecl  deriv_decls ;
180
   (rn_splice_decls,  src_fvs9) <- rnList rnSpliceDecl    splice_decls ;
181 182 183
      -- Haddock docs; no free vars
   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;

184
    last_tcg_env <- getGblEnv ;
185
   -- (I) Compute the results and return
186
   let {rn_group = HsGroup { hs_valds   = rn_val_decls,
187
                             hs_splcds  = rn_splice_decls,
188 189
                             hs_tyclds  = rn_tycl_decls,
                             hs_instds  = rn_inst_decls,
190
                             hs_derivds = rn_deriv_decls,
191 192 193 194 195 196 197 198
                             hs_fixds   = rn_fix_decls,
                             hs_warnds  = [], -- warns are returned in the tcg_env
                                             -- (see below) not in the HsGroup
                             hs_fords  = rn_foreign_decls,
                             hs_annds  = rn_ann_decls,
                             hs_defds  = rn_default_decls,
                             hs_ruleds = rn_rule_decls,
                             hs_vects  = rn_vect_decls,
199
                             hs_docs   = rn_docs } ;
200

201 202
        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_inst_decls rn_foreign_decls ;
        other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
203
        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
204 205
                              src_fvs5, src_fvs6, src_fvs7, src_fvs8,
                              src_fvs9] ;
206
                -- It is tiresome to gather the binders from type and class decls
207

208 209 210
        src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
                -- Instance decls may have occurrences of things bound in bind_dus
                -- so we must put other_fvs last
211

212
        final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
213 214
                        in -- we return the deprecs in the env, not in the HsGroup above
                        tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
215 216 217 218
       } ;

   traceRn (text "finish rnSrc" <+> ppr rn_group) ;
   traceRn (text "finish Dus" <+> ppr src_dus ) ;
219
   return (final_tcg_env, rn_group)
220
                    }}}}}
221 222 223 224 225 226

-- some utils because we do this a bunch above
-- compute and install the new env
inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
inNewEnv env cont = do e <- env
                       setGblEnv e $ cont e
227

228 229
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
-- This function could be defined lower down in the module hierarchy,
230
-- but there doesn't seem anywhere very logical to put it.
231
addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
232 233 234

rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
rnList f xs = mapFvRn (wrapLocFstM f) xs
235

Austin Seipp's avatar
Austin Seipp committed
236 237 238
{-
*********************************************************
*                                                       *
239
        HsDoc stuff
Austin Seipp's avatar
Austin Seipp committed
240 241 242
*                                                       *
*********************************************************
-}
243

244
rnDocDecl :: DocDecl -> RnM DocDecl
245
rnDocDecl (DocCommentNext doc) = do
246 247
  rn_doc <- rnHsDoc doc
  return (DocCommentNext rn_doc)
248
rnDocDecl (DocCommentPrev doc) = do
249 250 251 252 253 254 255 256
  rn_doc <- rnHsDoc doc
  return (DocCommentPrev rn_doc)
rnDocDecl (DocCommentNamed str doc) = do
  rn_doc <- rnHsDoc doc
  return (DocCommentNamed str rn_doc)
rnDocDecl (DocGroup lev doc) = do
  rn_doc <- rnHsDoc doc
  return (DocGroup lev rn_doc)
257

Austin Seipp's avatar
Austin Seipp committed
258 259 260
{-
*********************************************************
*                                                       *
261
        Source-code fixity declarations
Austin Seipp's avatar
Austin Seipp committed
262 263 264
*                                                       *
*********************************************************
-}
265

266
rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
267 268 269
-- Rename the fixity decls, so we can put
-- the renamed decls in the renamed syntax tree
-- Errors if the thing being fixed is not defined locally.
270 271 272
--
-- The returned FixitySigs are not actually used for anything,
-- except perhaps the GHCi API
273
rnSrcFixityDecls bndr_set fix_decls
274 275 276
  = do fix_decls <- mapM rn_decl fix_decls
       return (concat fix_decls)
  where
277
    sig_ctxt = TopSigCtxt bndr_set
278

279
    rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
280 281 282 283
        -- GHC extension: look up both the tycon and data con
        -- for con-like things; hence returning a list
        -- If neither are in scope, report an error; otherwise
        -- return a fixity sig for each (slightly odd)
284 285 286 287 288 289 290
    rn_decl (L loc (FixitySig fnames fixity))
      = do names <- mapM lookup_one fnames
           return [ L loc (FixitySig name fixity)
                  | name <- names ]

    lookup_one :: Located RdrName -> RnM [Located Name]
    lookup_one (L name_loc rdr_name)
291
      = setSrcSpan name_loc $
292
                    -- this lookup will fail if the definition isn't local
293
        do names <- lookupLocalTcNames sig_ctxt what rdr_name
294
           return [ L name_loc name | name <- names ]
295
    what = ptext (sLit "fixity signature")
296

Austin Seipp's avatar
Austin Seipp committed
297 298 299
{-
*********************************************************
*                                                       *
300
        Source-code deprecations declarations
Austin Seipp's avatar
Austin Seipp committed
301 302
*                                                       *
*********************************************************
303

304 305 306
Check that the deprecated names are defined, are defined locally, and
that there are no duplicate deprecations.

307 308
It's only imported deprecations, dealt with in RnIfaces, that we
gather them together.
Austin Seipp's avatar
Austin Seipp committed
309
-}
310

311
-- checks that the deprecations are defined locally, and that there are no duplicates
Alan Zimmerman's avatar
Alan Zimmerman committed
312
rnSrcWarnDecls :: NameSet -> [LWarnDecls RdrName] -> RnM Warnings
313
rnSrcWarnDecls _ []
314
  = return NoWarnings
315

Alan Zimmerman's avatar
Alan Zimmerman committed
316
rnSrcWarnDecls bndr_set decls'
317
  = do { -- check for duplicates
318
       ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
319
                          in addErrAt loc (dupWarnDecl lrdr' rdr))
320 321 322
               warn_rdr_dups
       ; pairs_s <- mapM (addLocM rn_deprec) decls
       ; return (WarnSome ((concat pairs_s))) }
323
 where
Alan Zimmerman's avatar
Alan Zimmerman committed
324 325
   decls = concatMap (\(L _ d) -> wd_warnings d) decls'

326
   sig_ctxt = TopSigCtxt bndr_set
327

Alan Zimmerman's avatar
Alan Zimmerman committed
328
   rn_deprec (Warning rdr_names txt)
329
       -- ensures that the names are defined locally
Alan Zimmerman's avatar
Alan Zimmerman committed
330 331
     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
                                rdr_names
332
          ; return [(nameOccName name, txt) | name <- names] }
333

334 335
   what = ptext (sLit "deprecation")

Alan Zimmerman's avatar
Alan Zimmerman committed
336 337
   warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
                                               decls
338 339 340 341 342 343 344

findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))

-- look for duplicates among the OccNames;
-- we check that the names are defined above
-- invt: the lists returned by findDupsEq always have at least two elements
345

Ian Lynagh's avatar
Ian Lynagh committed
346
dupWarnDecl :: Located RdrName -> RdrName -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
347
-- Located RdrName -> DeprecDecl RdrName -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
348 349
dupWarnDecl (L loc _) rdr_name
  = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
Ian Lynagh's avatar
Ian Lynagh committed
350
          ptext (sLit "also at ") <+> ppr loc]
351

Austin Seipp's avatar
Austin Seipp committed
352 353 354
{-
*********************************************************
*                                                      *
355
\subsection{Annotation declarations}
Austin Seipp's avatar
Austin Seipp committed
356 357 358
*                                                      *
*********************************************************
-}
359 360

rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
Alan Zimmerman's avatar
Alan Zimmerman committed
361
rnAnnDecl ann@(HsAnnotation s provenance expr)
362 363 364 365
  = addErrCtxt (annCtxt ann) $
    do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
       ; (expr', expr_fvs) <- setStage (Splice False) $
                              rnLExpr expr
Alan Zimmerman's avatar
Alan Zimmerman committed
366 367
       ; return (HsAnnotation s provenance' expr',
                 provenance_fvs `plusFV` expr_fvs) }
368 369 370

rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
rnAnnProvenance provenance = do
371
    provenance' <- traverse lookupTopBndrRn provenance
372 373
    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))

Austin Seipp's avatar
Austin Seipp committed
374 375 376
{-
*********************************************************
*                                                      *
377
\subsection{Default declarations}
Austin Seipp's avatar
Austin Seipp committed
378 379 380
*                                                      *
*********************************************************
-}
381

Ian Lynagh's avatar
Ian Lynagh committed
382
rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
383
rnDefaultDecl (DefaultDecl tys)
384
  = do { (tys', fvs) <- rnLHsTypes doc_str tys
385
       ; return (DefaultDecl tys', fvs) }
386
  where
dreixel's avatar
dreixel committed
387
    doc_str = DefaultDeclCtx
388

Austin Seipp's avatar
Austin Seipp committed
389 390 391
{-
*********************************************************
*                                                      *
392
\subsection{Foreign declarations}
Austin Seipp's avatar
Austin Seipp committed
393 394 395
*                                                      *
*********************************************************
-}
396

Ian Lynagh's avatar
Ian Lynagh committed
397
rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
398
rnHsForeignDecl (ForeignImport name ty _ spec)
399 400
  = do { topEnv :: HscEnv <- getTopEnv
       ; name' <- lookupLocatedTopBndrRn name
401
       ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
402

403
        -- Mark any PackageTarget style imports as coming from the current package
404 405
       ; let packageKey = thisPackage $ hsc_dflags topEnv
             spec'      = patchForeignImport packageKey spec
406

407
       ; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) }
408

409
rnHsForeignDecl (ForeignExport name ty _ spec)
410
  = do { name' <- lookupLocatedOccRn name
411
       ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
412
       ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
413 414 415
        -- NB: a foreign export is an *occurrence site* for name, so
        --     we add it to the free-variable list.  It might, for example,
        --     be imported from another module
416

417
-- | For Windows DLLs we need to know what packages imported symbols are from
418 419 420
--      to generate correct calls. Imported symbols are tagged with the current
--      package, so if they get inlined across a package boundry we'll still
--      know where they're from.
421
--
422
patchForeignImport :: PackageKey -> ForeignImport -> ForeignImport
423 424
patchForeignImport packageKey (CImport cconv safety fs spec src)
        = CImport cconv safety fs (patchCImportSpec packageKey spec) src
425

426 427
patchCImportSpec :: PackageKey -> CImportSpec -> CImportSpec
patchCImportSpec packageKey spec
428
 = case spec of
429
        CFunction callTarget    -> CFunction $ patchCCallTarget packageKey callTarget
430
        _                       -> spec
431

432 433
patchCCallTarget :: PackageKey -> CCallTarget -> CCallTarget
patchCCallTarget packageKey callTarget =
434
  case callTarget of
435 436 437
  StaticTarget src label Nothing isFun
                              -> StaticTarget src label (Just packageKey) isFun
  _                           -> callTarget
438

Austin Seipp's avatar
Austin Seipp committed
439 440 441
{-
*********************************************************
*                                                      *
442
\subsection{Instance declarations}
Austin Seipp's avatar
Austin Seipp committed
443 444 445
*                                                      *
*********************************************************
-}
446

Ian Lynagh's avatar
Ian Lynagh committed
447
rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
448
rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
449 450 451
  = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
       ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }

452
rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
453 454 455 456 457 458 459 460 461 462
  = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
       ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }

rnSrcInstDecl (ClsInstD { cid_inst = cid })
  = do { (cid', fvs) <- rnClsInstDecl cid
       ; return (ClsInstD { cid_inst = cid' }, fvs) }

rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
                           , cid_sigs = uprags, cid_tyfam_insts = ats
463
                           , cid_overlap_mode = oflag
464
                           , cid_datafam_insts = adts })
465
        -- Used for both source and interface file decls
466
  = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
467
       ; case splitLHsInstDeclTy_maybe inst_ty' of {
468 469
           Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
                                          , cid_sigs = [], cid_tyfam_insts = []
470
                                          , cid_overlap_mode = oflag
471
                                          , cid_datafam_insts = [] }
472
                             , inst_fvs) ;
473 474 475
           Just (inst_tyvars, _, L _ cls,_) ->

    do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
476
             ktv_names = hsLKiTyVarNames inst_tyvars
477 478 479

       -- Rename the associated types, and type signatures
       -- Both need to have the instance type variables in scope
480
       ; traceRn (text "rnSrcInstDecl"  <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
481
       ; ((ats', adts', other_sigs'), more_fvs)
482
             <- extendTyVarEnvFVRn ktv_names $
483
                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
484
                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts
485
                   ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
486 487
                   ; return ( (ats', adts', other_sigs')
                            , at_fvs `plusFV` adt_fvs `plusFV` sig_fvs) }
488

489 490 491 492
        -- Rename the bindings
        -- The typechecker (not the renamer) checks that all
        -- the bindings are for the right class
        -- (Slightly strangely) when scoped type variables are on, the
493
        -- forall-d tyvars scope over the method bindings too
494
       ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $
495
                                rnMethodBinds cls (mkSigTvFn other_sigs')
496 497 498 499 500 501 502 503
                                                  mbinds

        -- Rename the SPECIALISE instance pramas
        -- Annoyingly the type variables are not in scope here,
        -- so that      instance Eq a => Eq (T a) where
        --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
        -- works OK. That's why we did the partition game above
        --
504
       ; (spec_inst_prags', spec_inst_fvs)
505
             <- renameSigs (InstDeclCtxt cls) spec_inst_prags
506

507
       ; let uprags' = spec_inst_prags' ++ other_sigs'
508
             all_fvs = meth_fvs `plusFV` more_fvs
509
                          `plusFV` spec_inst_fvs
510
                          `plusFV` inst_fvs
511 512
       ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
                             , cid_sigs = uprags', cid_tyfam_insts = ats'
513
                             , cid_overlap_mode = oflag
514
                             , cid_datafam_insts = adts' },
515
                 all_fvs) } } }
516 517 518 519 520
             -- We return the renamed associated data type declarations so
             -- that they can be entered into the list of type declarations
             -- for the binding group, but we also keep a copy in the instance.
             -- The latter is needed for well-formedness checks in the type
             -- checker (eg, to ensure that all ATs of the instance actually
521 522 523 524 525
             -- receive a declaration).
             -- NB: Even the copies in the instance declaration carry copies of
             --     the instance context after renaming.  This is a bit
             --     strange, but should not matter (and it would be more work
             --     to remove the context).
526

527 528 529 530 531 532
rnFamInstDecl :: HsDocContext
              -> Maybe (Name, [Name])
              -> Located RdrName
              -> [LHsType RdrName]
              -> rhs
              -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
533 534
              -> RnM (Located Name, HsWithBndrs Name [LHsType Name], rhs',
                      FreeVars)
535
rnFamInstDecl doc mb_cls tycon pats payload rnPayload
536
  = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
537 538 539 540
       ; let loc = case pats of
                     []             -> pprPanic "rnFamInstDecl" (ppr tycon)
                     (L loc _ : []) -> loc
                     (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
541
             (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
542 543


544 545 546
       ; rdr_env  <- getLocalRdrEnv
       ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
       ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
547
             -- All the free vars of the family patterns
548
             -- with a sensible binding location
549 550 551
       ; ((pats', payload'), fvs)
              <- bindLocalNamesFV kv_names $
                 bindLocalNamesFV tv_names $
552 553
                 do { (pats', pat_fvs) <- rnLHsTypes doc pats
                    ; (payload', rhs_fvs) <- rnPayload doc payload
554

555
                         -- See Note [Renaming associated types]
556
                    ; let lhs_names = mkNameSet kv_names `unionNameSet` mkNameSet tv_names
557 558 559 560 561 562
                          bad_tvs = case mb_cls of
                                      Nothing           -> []
                                      Just (_,cls_tkvs) -> filter is_bad cls_tkvs

                          is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
                                        && not (cls_tkv `elemNameSet` lhs_names)
563 564

                    ; unless (null bad_tvs) (badAssocRhs bad_tvs)
565
                    ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
566

567 568

       ; let all_fvs = fvs `addOneFV` unLoc tycon'
569
       ; return (tycon',
thomasw's avatar
thomasw committed
570 571
                 HsWB { hswb_cts = pats', hswb_kvs = kv_names,
                        hswb_tvs = tv_names, hswb_wcs = [] },
572 573
                 payload',
                 all_fvs) }
574
             -- type instance => use, hence addOneFV
575 576 577 578

rnTyFamInstDecl :: Maybe (Name, [Name])
                -> TyFamInstDecl RdrName
                -> RnM (TyFamInstDecl Name, FreeVars)
579 580 581
rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
  = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
       ; return (TyFamInstDecl { tfid_eqn = L loc eqn'
582 583 584 585 586
                               , tfid_fvs = fvs }, fvs) }

rnTyFamInstEqn :: Maybe (Name, [Name])
               -> TyFamInstEqn RdrName
               -> RnM (TyFamInstEqn Name, FreeVars)
587 588 589
rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
                                , tfe_pats  = HsWB { hswb_cts = pats }
                                , tfe_rhs   = rhs })
590 591
  = do { (tycon', pats', rhs', fvs) <-
           rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609
       ; return (TyFamEqn { tfe_tycon = tycon'
                          , tfe_pats  = pats'
                          , tfe_rhs   = rhs' }, fvs) }

rnTyFamDefltEqn :: Name
                -> TyFamDefltEqn RdrName
                -> RnM (TyFamDefltEqn Name, FreeVars)
rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
                              , tfe_pats  = tyvars
                              , tfe_rhs   = rhs })
  = bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
    do { tycon'      <- lookupFamInstName (Just cls) tycon
       ; (rhs', fvs) <- rnLHsType ctx rhs
       ; return (TyFamEqn { tfe_tycon = tycon'
                          , tfe_pats  = tyvars'
                          , tfe_rhs   = rhs' }, fvs) }
  where
    ctx = TyFamilyCtx tycon
610 611 612 613 614 615 616 617 618 619 620 621 622

rnDataFamInstDecl :: Maybe (Name, [Name])
                  -> DataFamInstDecl RdrName
                  -> RnM (DataFamInstDecl Name, FreeVars)
rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
                                          , dfid_pats  = HsWB { hswb_cts = pats }
                                          , dfid_defn  = defn })
  = do { (tycon', pats', defn', fvs) <-
           rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
       ; return (DataFamInstDecl { dfid_tycon = tycon'
                                 , dfid_pats  = pats'
                                 , dfid_defn  = defn'
                                 , dfid_fvs   = fvs }, fvs) }
623

Austin Seipp's avatar
Austin Seipp committed
624
-- Renaming of the associated types in instances.
625

626
-- Rename associated type family decl in class
627
rnATDecls :: Name      -- Class
628
          -> [LFamilyDecl RdrName]
629
          -> RnM ([LFamilyDecl Name], FreeVars)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
630 631
rnATDecls cls at_decls
  = rnList (rnFamDecl (Just cls)) at_decls
632

633 634 635 636
rnATInstDecls :: (Maybe (Name, [Name]) ->    -- The function that renames
                  decl RdrName ->            -- an instance. rnTyFamInstDecl
                  RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl
              -> Name      -- Class
637
              -> LHsTyVarBndrs Name
638
              -> [Located (decl RdrName)]
639 640
              -> RnM ([Located (decl Name)], FreeVars)
-- Used for data and type family defaults in a class decl
641
-- and the family instance declarations in an instance
642 643
--
-- NB: We allow duplicate associated-type decls;
644
--     See Note [Associated type instances] in TcInstDcls
645 646
rnATInstDecls rnFun cls hs_tvs at_insts
  = rnList (rnFun (Just (cls, tv_ns))) at_insts
647
  where
648 649
    tv_ns = hsLKiTyVarNames hs_tvs
    -- See Note [Renaming associated types]
650

Austin Seipp's avatar
Austin Seipp committed
651
{-
652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677
Note [Renaming associated types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Check that the RHS of the decl mentions only type variables
bound on the LHS.  For example, this is not ok
   class C a b where
      type F a x :: *
   instance C (p,q) r where
      type F (p,q) x = (x, r)   -- BAD: mentions 'r'
c.f. Trac #5515

The same thing applies to kind variables, of course (Trac #7938, #9574):
   class Funct f where
      type Codomain f :: *
   instance Funct ('KProxy :: KProxy o) where
      type Codomain 'KProxy = NatTr (Proxy :: o -> *)
Here 'o' is mentioned on the RHS of the Codomain function, but
not on the LHS.

All this applies only for *instance* declarations.  In *class*
declarations there is no RHS to worry about, and the class variables
can all be in scope (Trac #5862):
    class Category (x :: k -> k -> *) where
      type Ob x :: k -> Constraint
      id :: Ob x a => x a a
      (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
Here 'k' is in scope in the kind signature, just like 'x'.
Austin Seipp's avatar
Austin Seipp committed
678
-}
679

680
extendTyVarEnvForMethodBinds :: [Name]
Gergő Érdi's avatar
Gergő Érdi committed
681 682
                             -> RnM (LHsBinds Name, FreeVars)
                             -> RnM (LHsBinds Name, FreeVars)
683 684 685
-- For the method bindings in class and instance decls, we extend
-- the type variable environment iff -XScopedTypeVariables

686
extendTyVarEnvForMethodBinds ktv_names thing_inside
687 688 689 690 691
  = do  { scoped_tvs <- xoptM Opt_ScopedTypeVariables
        ; if scoped_tvs then
                extendTyVarEnvFVRn ktv_names thing_inside
          else
                thing_inside }
692

Austin Seipp's avatar
Austin Seipp committed
693 694 695
{-
*********************************************************
*                                                      *
696
\subsection{Stand-alone deriving declarations}
Austin Seipp's avatar
Austin Seipp committed
697 698 699
*                                                      *
*********************************************************
-}
700 701

rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
702
rnSrcDerivDecl (DerivDecl ty overlap)
703
  = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
704
       ; unless standalone_deriv_ok (addErr standaloneDerivErr)
705
       ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
706
       ; return (DerivDecl ty' overlap, fvs) }
707 708

standaloneDerivErr :: SDoc
709
standaloneDerivErr
710
  = hang (ptext (sLit "Illegal standalone deriving declaration"))
711
       2 (ptext (sLit "Use StandaloneDeriving to enable this extension"))
712

Austin Seipp's avatar
Austin Seipp committed
713 714 715
{-
*********************************************************
*                                                      *
716
\subsection{Rules}
Austin Seipp's avatar
Austin Seipp committed
717 718 719
*                                                      *
*********************************************************
-}
720

Alan Zimmerman's avatar
Alan Zimmerman committed
721 722 723 724 725
rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars)
rnHsRuleDecls (HsRules src rules)
  = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
       ; return (HsRules src rn_rules,fvs) }

Ian Lynagh's avatar
Ian Lynagh committed
726 727
rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
728
  = do { let rdr_names_w_loc = map get_var vars
729 730
       ; checkDupRdrNames rdr_names_w_loc
       ; checkShadowedRdrNames rdr_names_w_loc
731
       ; names <- newLocalBndrsRn rdr_names_w_loc
732
       ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->
733 734
    do { (lhs', fv_lhs') <- rnLExpr lhs
       ; (rhs', fv_rhs') <- rnLExpr rhs
735
       ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
736
       ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
737
                 fv_lhs' `plusFV` fv_rhs') } }
738
  where
739 740
    get_var (L _ (RuleBndrSig v _)) = v
    get_var (L _ (RuleBndr v)) = v
741

742 743
bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name]
               -> ([LRuleBndr Name] -> RnM (a, FreeVars))
744 745 746 747 748 749
               -> RnM (a, FreeVars)
bindHsRuleVars rule_name vars names thing_inside
  = go vars names $ \ vars' ->
    bindLocalNamesFV names (thing_inside vars')
  where
    doc = RuleCtx rule_name
750

751
    go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
752
      = go vars ns $ \ vars' ->
753
        thing_inside (L l (RuleBndr (L loc n)) : vars')
754

755
    go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
756
      = rnHsBndrSig doc bsig $ \ bsig' ->
757
        go vars ns $ \ vars' ->
758
        thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
759 760 761

    go [] [] thing_inside = thing_inside []
    go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
762

Austin Seipp's avatar
Austin Seipp committed
763
{-
764 765 766 767
Note [Rule LHS validity checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Check the shape of a transformation rule LHS.  Currently we only allow
LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
768
@forall@'d variables.
769

770 771 772
We used restrict the form of the 'ei' to prevent you writing rules
with LHSs with a complicated desugaring (and hence unlikely to match);