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

4
\section[RnNames]{Extracting imported and top-level names in scope}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

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

9
module RnNames (
Matthew Pickering's avatar
Matthew Pickering committed
10
        rnImports, getLocalNonValBinders, newRecordSelector,
11
        rnExports, extendGlobalRdrEnvRn,
Erik de Castro Lopo's avatar
Erik de Castro Lopo committed
12
        gresFromAvails,
13
        calculateAvails,
Erik de Castro Lopo's avatar
Erik de Castro Lopo committed
14
        reportUnusedNames,
Gergő Érdi's avatar
Gergő Érdi committed
15
        checkConName
16
17
18
19
    ) where

#include "HsVersions.h"

20
import DynFlags
Ian Lynagh's avatar
Ian Lynagh committed
21
import HsSyn
Adam Gundry's avatar
Adam Gundry committed
22
import TcEnv
23
import RnEnv
24
import RnHsDoc          ( rnHsDoc )
25
import LoadIface        ( loadSrcInterface )
26
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
27
28
import PrelNames
import Module
29
import Name
30
import NameEnv
31
import NameSet
32
import Avail
Adam Gundry's avatar
Adam Gundry committed
33
import FieldLabel
34
35
import HscTypes
import RdrName
36
import RdrHsSyn        ( setRdrNameSpace )
37
import Outputable
38
import Maybes
39
import SrcLoc
40
import BasicTypes      ( TopLevelFlag(..), StringLiteral(..) )
41
import ErrUtils
42
import Util
43
import FastString
Adam Gundry's avatar
Adam Gundry committed
44
import FastStringEnv
45
import ListSetOps
46
47
import Id
import Type
48
import PatSyn
49
import qualified GHC.LanguageExtensions as LangExt
dterei's avatar
dterei committed
50

Ian Lynagh's avatar
Ian Lynagh committed
51
import Control.Monad
Adam Gundry's avatar
Adam Gundry committed
52
import Data.Either      ( partitionEithers, isRight, rights )
53
-- import qualified Data.Foldable as Foldable
54
import Data.Map         ( Map )
55
import qualified Data.Map as Map
Adam Gundry's avatar
Adam Gundry committed
56
57
import Data.Ord         ( comparing )
import Data.List        ( partition, (\\), find, sortBy )
58
-- import qualified Data.Set as Set
59
import System.FilePath  ((</>))
dterei's avatar
dterei committed
60
import System.IO
61

Austin Seipp's avatar
Austin Seipp committed
62
63
64
{-
************************************************************************
*                                                                      *
65
\subsection{rnImports}
Austin Seipp's avatar
Austin Seipp committed
66
67
*                                                                      *
************************************************************************
68

69
70
71
72
73
74
75
76
77
Note [Tracking Trust Transitively]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we import a package as well as checking that the direct imports are safe
according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check]
we must also check that these rules hold transitively for all dependent modules
and packages. Doing this without caching any trust information would be very
slow as we would need to touch all packages and interface files a module depends
on. To avoid this we make use of the property that if a modules Safe Haskell
mode changes, this triggers a recompilation from that module in the dependcy
dterei's avatar
dterei committed
78
79
80
81
82
83
84
85
graph. So we can just worry mostly about direct imports.

There is one trust property that can change for a package though without
recompliation being triggered: package trust. So we must check that all
packages a module tranitively depends on to be trusted are still trusted when
we are compiling this module (as due to recompilation avoidance some modules
below may not be considered trusted any more without recompilation being
triggered).
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119

We handle this by augmenting the existing transitive list of packages a module M
depends on with a bool for each package that says if it must be trusted when the
module M is being checked for trust. This list of trust required packages for a
single import is gathered in the rnImportDecl function and stored in an
ImportAvails data structure. The union of these trust required packages for all
imports is done by the rnImports function using the combine function which calls
the plusImportAvails function that is a union operation for the ImportAvails
type. This gives us in an ImportAvails structure all packages required to be
trusted for the module we are currently compiling. Checking that these packages
are still trusted (and that direct imports are trusted) is done in
HscMain.checkSafeImports.

See the note below, [Trust Own Package] for a corner case in this method and
how its handled.


Note [Trust Own Package]
~~~~~~~~~~~~~~~~~~~~~~~~
There is a corner case of package trust checking that the usual transitive check
doesn't cover. (For how the usual check operates see the Note [Tracking Trust
Transitively] below). The case is when you import a -XSafe module M and M
imports a -XTrustworthy module N. If N resides in a different package than M,
then the usual check works as M will record a package dependency on N's package
and mark it as required to be trusted. If N resides in the same package as M
though, then importing M should require its own package be trusted due to N
(since M is -XSafe so doesn't create this requirement by itself). The usual
check fails as a module doesn't record a package dependency of its own package.
So instead we now have a bool field in a modules interface file that simply
states if the module requires its own package to be trusted. This field avoids
us having to load all interface files that the module depends on to see if one
is trustworthy.


120
121
122
123
124
125
126
127
128
129
Note [Trust Transitive Property]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
So there is an interesting design question in regards to transitive trust
checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch
of modules and packages, some packages it requires to be trusted as its using
-XTrustworthy modules from them. Now if I have a module A that doesn't use safe
haskell at all and simply imports B, should A inherit all the the trust
requirements from B? Should A now also require that a package p is trusted since
B required it?

dterei's avatar
dterei committed
130
We currently say no but saying yes also makes sense. The difference is, if a
131
module M that doesn't use Safe Haskell imports a module N that does, should all
132
133
134
135
136
137
138
the trusted package requirements be dropped since M didn't declare that it cares
about Safe Haskell (so -XSafe is more strongly associated with the module doing
the importing) or should it be done still since the author of the module N that
uses Safe Haskell said they cared (so -XSafe is more strongly associated with
the module that was compiled that used it).

Going with yes is a simpler semantics we think and harder for the user to stuff
139
140
up but it does mean that Safe Haskell will affect users who don't care about
Safe Haskell as they might grab a package from Cabal which uses safe haskell (say
141
142
143
144
145
146
network) and that packages imports -XTrustworthy modules from another package
(say bytestring), so requires that package is trusted. The user may now get
compilation errors in code that doesn't do anything with Safe Haskell simply
because they are using the network package. They will have to call 'ghc-pkg
trust network' to get everything working. Due to this invasive nature of going
with yes we have gone with no for now.
Austin Seipp's avatar
Austin Seipp committed
147
-}
148

149
150
151
152
-- | Process Import Decls.  See 'rnImportDecl' for a description of what
-- the return types represent.
-- Note: Do the non SOURCE ones first, so that we get a helpful warning
-- for SOURCE ones that are unnecessary
153
154
rnImports :: [LImportDecl RdrName]
          -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
dterei's avatar
dterei committed
155
156
157
158
rnImports imports = do
    this_mod <- getModule
    let (source, ordinary) = partition is_source_import imports
        is_source_import d = ideclSource (unLoc d)
159
160
    stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary
    stuff2 <- mapAndReportM (rnImportDecl this_mod) source
dterei's avatar
dterei committed
161
162
163
164
165
166
167
168
    -- Safe Haskell: See Note [Tracking Trust Transitively]
    let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)
    return (decls, rdr_env, imp_avails, hpc_usage)

  where
    combine :: [(LImportDecl Name,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]
            -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
    combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False)
Erik de Castro Lopo's avatar
Erik de Castro Lopo committed
169

dterei's avatar
dterei committed
170
171
172
173
174
175
176
    plus (decl,  gbl_env1, imp_avails1,hpc_usage1)
         (decls, gbl_env2, imp_avails2,hpc_usage2)
      = ( decl:decls,
          gbl_env1 `plusGlobalRdrEnv` gbl_env2,
          imp_avails1 `plusImportAvails` imp_avails2,
          hpc_usage1 || hpc_usage2 )

177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
-- | Given a located import declaration @decl@ from @this_mod@,
-- calculate the following pieces of information:
--
--  1. An updated 'LImportDecl', where all unresolved 'RdrName' in
--     the entity lists have been resolved into 'Name's,
--
--  2. A 'GlobalRdrEnv' representing the new identifiers that were
--     brought into scope (taking into account module qualification
--     and hiding),
--
--  3. 'ImportAvails' summarizing the identifiers that were imported
--     by this declaration, and
--
--  4. A boolean 'AnyHpcUsage' which is true if the imported module
--     used HPC.
dterei's avatar
dterei committed
192
rnImportDecl  :: Module -> LImportDecl RdrName
dterei's avatar
dterei committed
193
              -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)
Erik de Castro Lopo's avatar
Erik de Castro Lopo committed
194
rnImportDecl this_mod
195
196
197
198
             (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg
                                     , ideclSource = want_boot, ideclSafe = mod_safe
                                     , ideclQualified = qual_only, ideclImplicit = implicit
                                     , ideclAs = as_mod, ideclHiding = imp_details }))
199
  = setSrcSpan loc $ do
200

201
    when (isJust mb_pkg) $ do
202
        pkg_imports <- xoptM LangExt.PackageImports
203
204
        when (not pkg_imports) $ addErr packageImportErr

dterei's avatar
dterei committed
205
206
207
    -- If there's an error in loadInterface, (e.g. interface
    -- file not found) we get lots of spurious errors from 'filterImports'
    let imp_mod_name = unLoc loc_imp_mod_name
208
        doc = ppr imp_mod_name <+> text "is directly imported"
209

210
211
212
    -- Check for self-import, which confuses the typechecker (Trac #9032)
    -- ghc --make rejects self-import cycles already, but batch-mode may not
    -- at least not until TcIface.tcHiBootIface, which is too late to avoid
213
214
215
216
217
218
219
220
221
222
    -- typechecker crashes.  (Indirect self imports are not caught until
    -- TcIface, see #10337 tracking how to make this error better.)
    --
    -- Originally, we also allowed 'import {-# SOURCE #-} M', but this
    -- caused bug #10182: in one-shot mode, we should never load an hs-boot
    -- file for the module we are compiling into the EPS.  In principle,
    -- it should be possible to support this mode of use, but we would have to
    -- extend Provenance to support a local definition in a qualified location.
    -- For now, we don't support it, but see #10336
    when (imp_mod_name == moduleName this_mod &&
223
224
225
226
          (case mb_pkg of  -- If we have import "<pkg>" M, then we should
                           -- check that "<pkg>" is "this" (which is magic)
                           -- or the name of this_mod's package.  Yurgh!
                           -- c.f. GHC.findModule, and Trac #9997
227
             Nothing         -> True
228
             Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" ||
229
                            fsToUnitId pkg_fs == moduleUnitId this_mod))
230
         (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name))
231

dterei's avatar
dterei committed
232
233
    -- Check for a missing import list (Opt_WarnMissingImportList also
    -- checks for T(..) items but that is done in checkDodgyImport below)
234
    case imp_details of
235
236
237
        Just (False, _) -> return () -- Explicit import list
        _  | implicit   -> return () -- Do not bleat for implicit imports
           | qual_only  -> return ()
ian@well-typed.com's avatar
ian@well-typed.com committed
238
           | otherwise  -> whenWOptM Opt_WarnMissingImportList $
239
240
                           addWarn (Reason Opt_WarnMissingImportList)
                                   (missingImportListWarn imp_mod_name)
241

242
    iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg)
243

dterei's avatar
dterei committed
244
245
    -- Compiler sanity check: if the import didn't say
    -- {-# SOURCE #-} we should not get a hi-boot file
246
    WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do
dterei's avatar
dterei committed
247
248
249
250
251
252
253
254
255

    -- Issue a user warning for a redundant {- SOURCE -} import
    -- NB that we arrange to read all the ordinary imports before
    -- any of the {- SOURCE -} imports.
    --
    -- in --make and GHCi, the compilation manager checks for this,
    -- and indeed we shouldn't do it here because the existence of
    -- the non-boot module depends on the compilation order, which
    -- is not deterministic.  The hs-boot test can show this up.
256
    dflags <- getDynFlags
257
258
    warnIf NoReason
           (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))
259
           (warnRedundantSourceImport imp_mod_name)
260
    when (mod_safe && not (safeImportsOn dflags)) $
261
        addErr (text "safe import can't be used as Safe Haskell isn't on!"
262
263
                $+$ ptext (sLit $ "please enable Safe Haskell through either "
                                   ++ "Safe, Trustworthy or Unsafe"))
264

265
    let
dterei's avatar
dterei committed
266
        qual_mod_name = as_mod `orElse` imp_mod_name
267
268
269
270
        imp_spec  = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,
                                  is_dloc = loc, is_as = qual_mod_name }

    -- filter the imports according to the import declaration
271
    (new_imp_details, gres) <- filterImports iface imp_spec imp_details
272

273
274
275
276
    -- for certain error messages, we’d like to know what could be imported
    -- here, if everything were imported
    potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing

277
    let gbl_env = mkGlobalRdrEnv gres
278

279
280
        is_hiding | Just (True,_) <- imp_details = True
                  | otherwise                    = False
281

282
283
        -- should the import be safe?
        mod_safe' = mod_safe
284
285
                    || (not implicit && safeDirectImpsReq dflags)
                    || (implicit && safeImplicitImpsReq dflags)
286

287
288
289
290
291
292
    let imv = ImportedModsVal
            { imv_name        = qual_mod_name
            , imv_span        = loc
            , imv_is_safe     = mod_safe'
            , imv_is_hiding   = is_hiding
            , imv_all_exports = potential_gres
Joachim Breitner's avatar
Joachim Breitner committed
293
            , imv_qualified   = qual_only
294
            }
295
    let imports
296
297
          = (calculateAvails dflags iface mod_safe' want_boot)
                { imp_mods = unitModuleEnv (mi_module iface) [imv] }
298

299
    -- Complain if we import a deprecated module
ian@well-typed.com's avatar
ian@well-typed.com committed
300
    whenWOptM Opt_WarnWarningsDeprecations (
301
       case (mi_warns iface) of
302
303
          WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations)
                                (moduleWarn imp_mod_name txt)
304
          _           -> return ()
305
306
     )

307
308
    let new_imp_decl = L loc (decl { ideclSafe = mod_safe'
                                   , ideclHiding = new_imp_details })
309

310
    return (new_imp_decl, gbl_env, imports, mi_hpc iface)
311

312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
calculateAvails :: DynFlags
                -> ModIface
                -> IsSafeImport
                -> IsBootInterface
                -> ImportAvails
calculateAvails dflags iface mod_safe' want_boot =
  let imp_mod    = mi_module iface
      orph_iface = mi_orphan iface
      has_finsts = mi_finsts iface
      deps       = mi_deps iface
      trust      = getSafeMode $ mi_trust iface
      trust_pkg  = mi_trust_pkg iface

      -- If the module exports anything defined in this module, just
      -- ignore it.  Reason: otherwise it looks as if there are two
      -- local definition sites for the thing, and an error gets
      -- reported.  Easiest thing is just to filter them out up
      -- front. This situation only arises if a module imports
      -- itself, or another module that imported it.  (Necessarily,
      -- this invoves a loop.)
      --
      -- We do this *after* filterImports, so that if you say
      --      module A where
      --         import B( AType )
      --         type AType = ...
      --
      --      module B( AType ) where
      --         import {-# SOURCE #-} A( AType )
      --
      -- then you won't get a 'B does not export AType' message.


      -- Compute new transitive dependencies

      orphans | orph_iface = ASSERT( not (imp_mod `elem` dep_orphs deps) )
                             imp_mod : dep_orphs deps
              | otherwise  = dep_orphs deps

      finsts | has_finsts = ASSERT( not (imp_mod `elem` dep_finsts deps) )
                            imp_mod : dep_finsts deps
             | otherwise  = dep_finsts deps

356
      pkg = moduleUnitId (mi_module iface)
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404

      -- Does this import mean we now require our own pkg
      -- to be trusted? See Note [Trust Own Package]
      ptrust = trust == Sf_Trustworthy || trust_pkg

      (dependent_mods, dependent_pkgs, pkg_trust_req)
         | pkg == thisPackage dflags =
            -- Imported module is from the home package
            -- Take its dependent modules and add imp_mod itself
            -- Take its dependent packages unchanged
            --
            -- NB: (dep_mods deps) might include a hi-boot file
            -- for the module being compiled, CM. Do *not* filter
            -- this out (as we used to), because when we've
            -- finished dealing with the direct imports we want to
            -- know if any of them depended on CM.hi-boot, in
            -- which case we should do the hi-boot consistency
            -- check.  See LoadIface.loadHiBootInterface
            ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust)

         | otherwise =
            -- Imported module is from another package
            -- Dump the dependent modules
            -- Add the package imp_mod comes from to the dependent packages
            ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps))
                   , ppr pkg <+> ppr (dep_pkgs deps) )
            ([], (pkg, False) : dep_pkgs deps, False)

  in ImportAvails {
          imp_mods       = emptyModuleEnv, -- this gets filled in later
          imp_orphs      = orphans,
          imp_finsts     = finsts,
          imp_dep_mods   = mkModDeps dependent_mods,
          imp_dep_pkgs   = map fst $ dependent_pkgs,
          -- Add in the imported modules trusted package
          -- requirements. ONLY do this though if we import the
          -- module as a safe import.
          -- See Note [Tracking Trust Transitively]
          -- and Note [Trust Transitive Property]
          imp_trust_pkgs = if mod_safe'
                               then map fst $ filter snd dependent_pkgs
                               else [],
          -- Do we require our own pkg to be trusted?
          -- See Note [Trust Own Package]
          imp_trust_own_pkg = pkg_trust_req
     }


Ian Lynagh's avatar
Ian Lynagh committed
405
warnRedundantSourceImport :: ModuleName -> SDoc
406
warnRedundantSourceImport mod_name
407
  = text "Unnecessary {-# SOURCE #-} in the import of module"
408
          <+> quotes (ppr mod_name)
409

Austin Seipp's avatar
Austin Seipp committed
410
411
412
{-
************************************************************************
*                                                                      *
413
\subsection{importsFromLocalDecls}
Austin Seipp's avatar
Austin Seipp committed
414
415
*                                                                      *
************************************************************************
416
417

From the top-level declarations of this module produce
418
419
420
421
        * the lexical environment
        * the ImportAvails
created by its bindings.

422
423
Note [Top-level Names in Template Haskell decl quotes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
424
See also: Note [Interactively-bound Ids in GHCi] in HscTypes
425
          Note [Looking up Exact RdrNames] in RnEnv
426

427
428
Consider a Template Haskell declaration quotation like this:
      module M where
429
        f x = h [d| f = 3 |]
430
431
When renaming the declarations inside [d| ...|], we treat the
top level binders specially in two ways
432

433
434
1.  We give them an Internal Name, not (as usual) an External one.
    This is done by RnEnv.newTopSrcBinder.
435

436
437
2.  We make them *shadow* the outer bindings.
    See Note [GlobalRdrEnv shadowing]
438
439
440
441
442

3. We find out whether we are inside a [d| ... |] by testing the TH
   stage. This is a slight hack, because the stage field was really
   meant for the type checker, and here we are not interested in the
   fields of Brack, hence the error thunks in thRnBrack.
Austin Seipp's avatar
Austin Seipp committed
443
-}
444

445
extendGlobalRdrEnvRn :: [AvailInfo]
446
447
448
449
450
451
                     -> MiniFixityEnv
                     -> RnM (TcGblEnv, TcLclEnv)
-- Updates both the GlobalRdrEnv and the FixityEnv
-- We return a new TcLclEnv only because we might have to
-- delete some bindings from it;
-- see Note [Top-level Names in Template Haskell decl quotes]
452

453
extendGlobalRdrEnvRn avails new_fixities
454
  = do  { (gbl_env, lcl_env) <- getEnvs
455
        ; stage <- getStage
456
        ; isGHCi <- getIsGHCi
457
458
459
460
        ; let rdr_env  = tcg_rdr_env gbl_env
              fix_env  = tcg_fix_env gbl_env
              th_bndrs = tcl_th_bndrs lcl_env
              th_lvl   = thLevel stage
461
462
463
464

              -- Delete new_occs from global and local envs
              -- If we are in a TemplateHaskell decl bracket,
              --    we are going to shadow them
465
              -- See Note [GlobalRdrEnv shadowing]
466
              inBracket = isBrackStage stage
467

468
              lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }
469
                           -- See Note [GlobalRdrEnv shadowing]
470

471
472
473
              lcl_env2 | inBracket = lcl_env_TH
                       | otherwise = lcl_env

474
475
476
477
              -- Deal with shadowing: see Note [GlobalRdrEnv shadowing]
              want_shadowing = isGHCi || inBracket
              rdr_env1 | want_shadowing = shadowNames rdr_env new_names
                       | otherwise      = rdr_env
478

479
480
481
              lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs
                                                       [ (n, (TopLevel, th_lvl))
                                                       | n <- new_names ] }
482

483
        ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres
484

485
        ; let fix_env' = foldl extend_fix_env fix_env new_gres
486
              gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
487

488
        ; traceRn (text "extendGlobalRdrEnvRn 2" <+> (pprGlobalRdrEnv True rdr_env2))
489
        ; return (gbl_env', lcl_env3) }
490
  where
491
    new_names = concatMap availNames avails
492
    new_occs  = map nameOccName new_names
493

494
    -- If there is a fixity decl for the gre, add it to the fixity env
495
    extend_fix_env fix_env gre
496
497
498
499
500
      | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)
      = extendNameEnv fix_env name (FixItem occ fi)
      | otherwise
      = fix_env
      where
501
502
        name = gre_name gre
        occ  = greOccName gre
503

504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
    new_gres :: [GlobalRdrElt]  -- New LocalDef GREs, derived from avails
    new_gres = concatMap localGREsFromAvail avails

    add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv
    -- Extend the GlobalRdrEnv with a LocalDef GRE
    -- If there is already a LocalDef GRE with the same OccName,
    --    report an error and discard the new GRE
    -- This establishes INVARIANT 1 of GlobalRdrEnvs
    add_gre env gre
      | not (null dups)    -- Same OccName defined twice
      = do { addDupDeclErr (gre : dups); return env }

      | otherwise
      = return (extendGlobalRdrEnv env gre)
      where
        name = gre_name gre
        occ  = nameOccName name
        dups = filter isLocalGRE (lookupGlobalRdrEnv env occ)


{- *********************************************************************
*                                                                      *
    getLocalDeclBindersd@ returns the names for an HsDecl
             It's used for source code.
528

529
        *** See Note [The Naming story] in HsDecls ****
530
531
*                                                                      *
********************************************************************* -}
532

Erik de Castro Lopo's avatar
Erik de Castro Lopo committed
533
getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName
Adam Gundry's avatar
Adam Gundry committed
534
    -> RnM ((TcGblEnv, TcLclEnv), NameSet)
535
-- Get all the top-level binders bound the group *except*
536
-- for value bindings, which are treated separately
Simon Peyton Jones's avatar
Simon Peyton Jones committed
537
-- Specifically we return AvailInfo for
538
539
540
541
--      * type decls (incl constructors and record selectors)
--      * class decls (including class ops)
--      * associated types
--      * foreign imports
542
--      * value signatures (in hs-boot files only)
543

Erik de Castro Lopo's avatar
Erik de Castro Lopo committed
544
getLocalNonValBinders fixity_env
545
     (HsGroup { hs_valds  = binds,
546
547
                hs_tyclds = tycl_decls,
                hs_fords  = foreign_decls })
548
  = do  { -- Process all type/class decls *except* family instances
549
        ; let inst_decls = tycl_decls >>= group_instds
550
        ; overload_ok <- xoptM LangExt.DuplicateRecordFields
551
552
553
        ; (tc_avails, tc_fldss)
            <- fmap unzip $ mapM (new_tc overload_ok)
                                 (tyClGroupTyClDecls tycl_decls)
554
        ; traceRn (text "getLocalNonValBinders 1" <+> ppr tc_avails)
555
        ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
dterei's avatar
dterei committed
556
557
        ; setEnvs envs $ do {
            -- Bring these things into scope first
558
            -- See Note [Looking up family names in family instances]
559
560

          -- Process all family instances
dterei's avatar
dterei committed
561
          -- to bring new data constructors into scope
Adam Gundry's avatar
Adam Gundry committed
562
563
        ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok)
                                                   inst_decls
564
565

          -- Finish off with value binders:
566
          --    foreign decls and pattern synonyms for an ordinary module
dterei's avatar
dterei committed
567
          --    type sigs in case of a hs-boot file only
568
        ; is_boot <- tcIsHsBootOrSig
569
        ; let val_bndrs | is_boot   = hs_boot_sig_bndrs
570
                        | otherwise = for_hs_bndrs
571
        ; val_avails <- mapM new_simple val_bndrs
572

Adam Gundry's avatar
Adam Gundry committed
573
        ; let avails    = concat nti_availss ++ val_avails
574
575
              new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`
                          availsToNameSetWithSelectors tc_avails
Adam Gundry's avatar
Adam Gundry committed
576
              flds      = concat nti_fldss ++ concat tc_fldss
577
        ; traceRn (text "getLocalNonValBinders 2" <+> ppr avails)
Adam Gundry's avatar
Adam Gundry committed
578
579
580
581
582
583
584
        ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env

        -- Extend tcg_field_env with new fields (this used to be the
        -- work of extendRecordFieldEnv)
        ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds
              envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)

585
        ; traceRn (text "getLocalNonValBinders 3" <+> vcat [ppr flds, ppr field_env])
586
587
        ; return (envs, new_bndrs) } }
  where
588
    ValBindsIn _val_binds val_sigs = binds
589

590
    for_hs_bndrs :: [Located RdrName]
591
592
    for_hs_bndrs = hsForeignDeclsBinders foreign_decls

593
    -- In a hs-boot file, the value binders come from the
594
    --  *signatures*, and there should be no foreign binders
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
595
    hs_boot_sig_bndrs = [ L decl_loc (unLoc n)
596
                        | L decl_loc (TypeSig ns _) <- val_sigs, n <- ns]
597

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
598
599
      -- the SrcSpan attached to the input should be the span of the
      -- declaration, not just the name
600
    new_simple :: Located RdrName -> RnM AvailInfo
601
    new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
602
                            ; return (avail nm) }
603

Adam Gundry's avatar
Adam Gundry committed
604
605
606
607
608
    new_tc :: Bool -> LTyClDecl RdrName
           -> RnM (AvailInfo, [(Name, [FieldLabel])])
    new_tc overload_ok tc_decl -- NOT for type/data instances
        = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl
             ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs
Matthew Pickering's avatar
Matthew Pickering committed
609
             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
Adam Gundry's avatar
Adam Gundry committed
610
611
612
613
614
615
616
617
618
619
620
621
             ; let fld_env = case unLoc tc_decl of
                     DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'
                     _                            -> []
             ; return (AvailTC main_name names flds', fld_env) }


    -- Calculate the mapping from constructor names to fields, which
    -- will go in tcg_field_env. It's convenient to do this here where
    -- we are working with a single datatype definition.
    mk_fld_env :: HsDataDefn RdrName -> [Name] -> [FieldLabel] -> [(Name, [FieldLabel])]
    mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
      where
622
623
624
625
        find_con_flds (L _ (ConDeclH98 { con_name    = L _ rdr
                                       , con_details = RecCon cdflds }))
            = [( find_con_name rdr
               , concatMap find_con_decl_flds (unLoc cdflds) )]
Alan Zimmerman's avatar
Alan Zimmerman committed
626
627
628
629
630
        find_con_flds (L _ (ConDeclGADT
                              { con_names = rdrs
                              , con_type = (HsIB { hsib_body = res_ty})}))
            = map (\ (L _ rdr) -> ( find_con_name rdr
                                  , concatMap find_con_decl_flds cdflds))
Adam Gundry's avatar
Adam Gundry committed
631
                  rdrs
Alan Zimmerman's avatar
Alan Zimmerman committed
632
633
634
            where
              (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
              cdflds = case tau of
635
636
637
                 L _ (HsFunTy
                      (L _ (HsAppsTy
                        [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds
638
                 L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds
Alan Zimmerman's avatar
Alan Zimmerman committed
639
                 _                                    -> []
Adam Gundry's avatar
Adam Gundry committed
640
641
642
643
644
645
646
        find_con_flds _ = []

        find_con_name rdr
          = expectJust "getLocalNonValBinders/find_con_name" $
              find (\ n -> nameOccName n == rdrNameOcc rdr) names
        find_con_decl_flds (L _ x)
          = map find_con_decl_fld (cd_fld_names x)
647
        find_con_decl_fld  (L _ (FieldOcc (L _ rdr) _))
Adam Gundry's avatar
Adam Gundry committed
648
649
650
651
652
653
654
          = expectJust "getLocalNonValBinders/find_con_decl_fld" $
              find (\ fl -> flLabel fl == lbl) flds
          where lbl = occNameFS (rdrNameOcc rdr)

    new_assoc :: Bool -> LInstDecl RdrName
              -> RnM ([AvailInfo], [(Name, [FieldLabel])])
    new_assoc _ (L _ (TyFamInstD {})) = return ([], [])
Erik de Castro Lopo's avatar
Erik de Castro Lopo committed
655
656
      -- type instances don't bind new names

Adam Gundry's avatar
Adam Gundry committed
657
658
659
660
661
    new_assoc overload_ok (L _ (DataFamInstD d))
      = do { (avail, flds) <- new_di overload_ok Nothing d
           ; return ([avail], flds) }
    new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty
                                                      , cid_datafam_insts = adts })))
662
      | Just (L loc cls_rdr) <- getLHsInstDeclClass_maybe inst_ty
663
      = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
Adam Gundry's avatar
Adam Gundry committed
664
665
666
           ; (avails, fldss)
                    <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts
           ; return (avails, concat fldss) }
667
      | otherwise
Adam Gundry's avatar
Adam Gundry committed
668
669
      = return ([], [])    -- Do not crash on ill-formed instances
                           -- Eg   instance !Show Int   Trac #3811c
670

Adam Gundry's avatar
Adam Gundry committed
671
672
673
    new_di :: Bool -> Maybe Name -> DataFamInstDecl RdrName
                   -> RnM (AvailInfo, [(Name, [FieldLabel])])
    new_di overload_ok mb_cls ti_decl
674
        = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
Adam Gundry's avatar
Adam Gundry committed
675
676
             ; let (bndrs, flds) = hsDataFamInstBinders ti_decl
             ; sub_names <- mapM newTopSrcBinder bndrs
Matthew Pickering's avatar
Matthew Pickering committed
677
             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
Adam Gundry's avatar
Adam Gundry committed
678
679
680
681
682
683
684
685
             ; let avail    = AvailTC (unLoc main_name) sub_names flds'
                                  -- main_name is not bound here!
                   fld_env  = mk_fld_env (dfid_defn ti_decl) sub_names flds'
             ; return (avail, fld_env) }

    new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl RdrName
                   -> RnM (AvailInfo, [(Name, [FieldLabel])])
    new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d
686

Matthew Pickering's avatar
Matthew Pickering committed
687
688
newRecordSelector :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel
newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"
689
690
691
newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _))
  = do { selName <- newTopSrcBinder $ L loc $ field
       ; return $ qualFieldLbl { flSelector = selName } }
Matthew Pickering's avatar
Matthew Pickering committed
692
  where
693
694
695
696
697
698
699
700
701
702
    fieldOccName = occNameFS $ rdrNameOcc fld
    qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok
    field | isExact fld = fld
              -- use an Exact RdrName as is to preserve the bindings
              -- of an already renamer-resolved field and its use
              -- sites. This is needed to correctly support record
              -- selectors in Template Haskell. See Note [Binders in
              -- Template Haskell] in Convert.hs and Note [Looking up
              -- Exact RdrNames] in RnEnv.hs.
          | otherwise   = mkRdrUnqual (flSelector qualFieldLbl)
Matthew Pickering's avatar
Matthew Pickering committed
703

Austin Seipp's avatar
Austin Seipp committed
704
{-
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
Note [Looking up family names in family instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider

  module M where
    type family T a :: *
    type instance M.T Int = Bool

We might think that we can simply use 'lookupOccRn' when processing the type
instance to look up 'M.T'.  Alas, we can't!  The type family declaration is in
the *same* HsGroup as the type instance declaration.  Hence, as we are
currently collecting the binders declared in that HsGroup, these binders will
not have been added to the global environment yet.

Solution is simple: process the type family declarations first, extend
the environment, and then process the type instances.


Austin Seipp's avatar
Austin Seipp committed
723
724
************************************************************************
*                                                                      *
725
\subsection{Filtering imports}
Austin Seipp's avatar
Austin Seipp committed
726
727
*                                                                      *
************************************************************************
728
729
730
731

@filterImports@ takes the @ExportEnv@ telling what the imported module makes
available, and filters it through the import spec (if any).

732
733
Note [Dealing with imports]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
734
735
For import M( ies ), we take the mi_exports of M, and make
   imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
736
737
One entry for each Name that M exports; the AvailInfo is the
AvailInfo exported from M that exports that Name.
738
739
740
741
742
743
744
745
746
747

The situation is made more complicated by associated types. E.g.
   module M where
     class    C a    where { data T a }
     instance C Int  where { data T Int = T1 | T2 }
     instance C Bool where { data T Int = T3 }
Then M's export_avails are (recall the AvailTC invariant from Avails.hs)
  C(C,T), T(T,T1,T2,T3)
Notice that T appears *twice*, once as a child and once as a parent.
From this we construct the imp_occ_env
748
   C  -> (C,  C(C,T),        Nothing)
749
   T  -> (T,  T(T,T1,T2,T3), Just C)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
750
   T1 -> (T1, T(T,T1,T2,T3), Nothing)   -- similarly T2,T3
751

752
753
754
755
If we say
   import M( T(T1,T2) )
then we get *two* Avails:  C(T), T(T1,T2)

756
757
Note that the imp_occ_env will have entries for data constructors too,
although we never look up data constructors.
Austin Seipp's avatar
Austin Seipp committed
758
-}
759

760
filterImports
761
    :: ModIface
762
763
764
765
    -> ImpDeclSpec                     -- The span for the entire import decl
    -> Maybe (Bool, Located [LIE RdrName])    -- Import spec; True => hiding
    -> RnM (Maybe (Bool, Located [LIE Name]), -- Import spec w/ Names
            [GlobalRdrElt])                   -- Same again, but in GRE form
766
filterImports iface decl_spec Nothing
767
  = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface))
768
  where
769
    imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
770

771

772
filterImports iface decl_spec (Just (want_hiding, L l import_items))
773
  = do  -- check for errors, convert RdrNames to Names
774
        items1 <- mapM lookup_lie import_items
775
776
777

        let items2 :: [(LIE Name, AvailInfo)]
            items2 = concat items1
778
779
                -- NB the AvailInfo may have duplicates, and several items
                --    for the same parent; e.g N(x) and N(y)
780
781

            names  = availsToNameSet (map snd items2)
782
783
            keep n = not (n `elemNameSet` names)
            pruned_avails = filterAvails keep all_avails
784
            hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
785

786
            gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails
787
                 | otherwise   = concatMap (gresFromIE decl_spec) items2
788

789
        return (Just (want_hiding, L l (map fst items2)), gres)
790
  where
791
    all_avails = mi_exports iface
792

793
794
795
796
797
798
        -- See Note [Dealing with imports]
    imp_occ_env :: OccEnv (Name,        -- the name
                           AvailInfo,   -- the export item providing the name
                           Maybe Name)  -- the parent of associated types
    imp_occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing))
                                     | a <- all_avails, n <- availNames a]
799
      where
800
801
802
803
        -- See example in Note [Dealing with imports]
        -- 'combine' is only called for associated types which appear twice
        -- in the all_avails. In the example, we combine
        --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)
Adam Gundry's avatar
Adam Gundry committed
804
805
        combine (name1, a1@(AvailTC p1 _ []), mp1)
                (name2, a2@(AvailTC p2 _ []), mp2)
806
807
808
          = ASSERT( name1 == name2 && isNothing mp1 && isNothing mp2 )
            if p1 == name1 then (name1, a1, Just p2)
                           else (name1, a2, Just p1)
Ian Lynagh's avatar
Ian Lynagh committed
809
        combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)
810

811
812
813
814
815
    lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name)
    lookup_name rdr | isQual rdr              = failLookupWith (QualImportError rdr)
                    | Just succ <- mb_success = return succ
                    | otherwise               = failLookupWith BadImport
      where
816
        mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)
817

818
819
820
821
822
    lookup_lie :: LIE RdrName -> TcRn [(LIE Name, AvailInfo)]
    lookup_lie (L loc ieRdr)
        = do (stuff, warns) <- setSrcSpan loc $
                               liftM (fromMaybe ([],[])) $
                               run_lookup (lookup_ie ieRdr)
823
             mapM_ emit_warning warns
824
825
             return [ (L loc ie, avail) | (ie,avail) <- stuff ]
        where
826
            -- Warn when importing T(..) if T was exported abstractly
ian@well-typed.com's avatar
ian@well-typed.com committed
827
            emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $
828
              addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)
ian@well-typed.com's avatar
ian@well-typed.com committed
829
            emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $
830
              addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)
ian@well-typed.com's avatar
ian@well-typed.com committed
831
            emit_warning BadImportW = whenWOptM Opt_WarnDodgyImports $
832
              addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg BadImport)
833
834
835
836
837
838
839

            run_lookup :: IELookupM a -> TcRn (Maybe a)
            run_lookup m = case m of
              Failed err -> addErr (lookup_err_msg err) >> return Nothing
              Succeeded a -> return (Just a)

            lookup_err_msg err = case err of
840
              BadImport -> badImportItemErr iface decl_spec ieRdr all_avails
841
842
              IllegalImport -> illegalImportItemErr
              QualImportError rdr -> qualImportItemErr rdr
843
844
845
846
847
848
849
850

        -- For each import item, we convert its RdrNames to Names,
        -- and at the same time construct an AvailInfo corresponding
        -- to what is actually imported by this item.
        -- Returns Nothing on error.
        -- We return a list here, because in the case of an import
        -- item like C, if we are hiding, then C refers to *both* a
        -- type/class and a data constructor.  Moreover, when we import
851
852
        -- data constructors of an associated family, we need separate
        -- AvailInfos for the data constructors and the family (as they have
853
        -- different parents).  See Note [Dealing with imports]
854
855
    lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning])
    lookup_ie ie = handle_bad_import $ do
856
      case ie of
857
        IEVar (L l n) -> do
858
            (name, avail, _) <- lookup_name n
859
            return ([(IEVar (L l name), trimAvail avail name)], [])
860

861
        IEThingAll (L l tc) -> do
862
863
864
865
866
            (name, avail, mb_parent) <- lookup_name tc
            let warns = case avail of
                          Avail {}                     -- e.g. f(..)
                            -> [DodgyImport tc]

Adam Gundry's avatar
Adam Gundry committed
867
868
                          AvailTC _ subs fs
                            | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym
869
870
871
872
873
874
875
876
877
878
                            -> [DodgyImport tc]

                            | not (is_qual decl_spec)  -- e.g. import M( T(..) )
                            -> [MissingImportList]

                            | otherwise
                            -> []

                renamed_ie = IEThingAll (L l name)
                sub_avails = case avail of
Adam Gundry's avatar
Adam Gundry committed
879
880
                               Avail {}              -> []
                               AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]
881
            case mb_parent of
882
883
              Nothing     -> return ([(renamed_ie, avail)], warns)
                             -- non-associated ty/cls
Adam Gundry's avatar
Adam Gundry committed
884
              Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)
885
                             -- associated type
886

Alan Zimmerman's avatar
Alan Zimmerman committed
887
        IEThingAbs (L l tc)
888
889
890
891
892
893
894
895
            | want_hiding   -- hiding ( C )
                       -- Here the 'C' can be a data constructor
                       --  *or* a type/class, or even both
            -> let tc_name = lookup_name tc
                   dc_name = lookup_name (setRdrNameSpace tc srcDataName)
               in
               case catIELookupM [ tc_name, dc_name ] of
                 []    -> failLookupWith BadImport
Alan Zimmerman's avatar
Alan Zimmerman committed
896
                 names -> return ([mkIEThingAbs l name | name <- names], [])
897
898
            | otherwise
            -> do nameAvail <- lookup_name tc
Alan Zimmerman's avatar
Alan Zimmerman committed
899
                  return ([mkIEThingAbs l nameAvail], [])
900

901
902
        IEThingWith (L l rdr_tc) wc rdr_ns rdr_fs ->
          ASSERT2(null rdr_fs, ppr rdr_fs) do
Adam Gundry's avatar
Adam Gundry committed
903
           (name, AvailTC _ ns subflds, mb_parent) <- lookup_name rdr_tc
904
905

           -- Look up the children in the sub-names of the parent
Austin Seipp's avatar
Austin Seipp committed
906
           let subnames = case ns of   -- The tc is first in ns,
907
908
909
910
                            [] -> []   -- if it is there at all
                                       -- See the AvailTC Invariant in Avail.hs
                            (n1:ns1) | n1 == name -> ns1
                                     | otherwise  -> ns
Adam Gundry's avatar
Adam Gundry committed
911
912
913
914
915
916
           case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of
             Nothing                      -> failLookupWith BadImport
             Just (childnames, childflds) ->
               case mb_parent of
                 -- non-associated ty/cls
                 Nothing
917
                   -> return ([(IEThingWith (L l name) wc childnames childflds,
Adam Gundry's avatar
Adam Gundry committed
918
919
920
921
                               AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
                              [])
                 -- associated ty
                 Just parent
922
                   -> return ([(IEThingWith (L l name) wc childnames childflds,
Adam Gundry's avatar
Adam Gundry committed
923
                                AvailTC name (map unLoc childnames) (map unLoc childflds)),
924
                               (IEThingWith (L l name) wc childnames childflds,
Adam Gundry's avatar
Adam Gundry committed
925
926
                                AvailTC parent [name] [])],
                              [])
927

928
929
930
        _other -> failLookupWith IllegalImport
        -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed
        -- all errors.
931
932

      where
Alan Zimmerman's avatar
Alan Zimmerman committed
933
934
935
        mkIEThingAbs l (n, av, Nothing    ) = (IEThingAbs (L l n),
                                               trimAvail av n)
        mkIEThingAbs l (n, _,  Just parent) = (IEThingAbs (L l n),
Adam Gundry's avatar
Adam Gundry committed
936
                                               AvailTC parent [n] [])
937

938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
        handle_bad_import m = catchIELookup m $ \err -> case err of
          BadImport | want_hiding -> return ([], [BadImportW])
          _                       -> failLookupWith err

type IELookupM = MaybeErr IELookupError

data IELookupWarning
  = BadImportW
  | MissingImportList
  | DodgyImport RdrName
  -- NB. use the RdrName for reporting a "dodgy" import

data IELookupError
  = QualImportError RdrName
  | BadImport
  | IllegalImport

failLookupWith :: IELookupError -> IELookupM a
failLookupWith err = Failed err

catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a
catchIELookup m h = case m of
  Succeeded r -> return r
  Failed err  -> h err
962

963
964
catIELookupM :: [IELookupM a] -> [a]
catIELookupM ms = [ a | Succeeded a <- ms ]
965

Austin Seipp's avatar
Austin Seipp committed
966
967
968
{-
************************************************************************
*                                                                      *
969
\subsection{Import/Export Utils}
Austin Seipp's avatar
Austin Seipp committed
970
971
972
*                                                                      *
************************************************************************
-}
973

974
975
plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
plusAvail a1 a2
Erik de Castro Lopo's avatar
Erik de Castro Lopo committed
976
  | debugIsOn && availName a1 /= availName a2
977
  = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2])
Adam Gundry's avatar
Adam Gundry committed
978
979
980
981
plusAvail a1@(Avail {})         (Avail {})        = a1
plusAvail (AvailTC _ [] [])     a2@(AvailTC {})   = a2
plusAvail a1@(AvailTC {})       (AvailTC _ [] []) = a1
plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)
982
983
  = case (n1==s1, n2==s2) of  -- Maintain invariant the parent is first
       (True,True)   -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
Adam Gundry's avatar
Adam Gundry committed
984
                                   (fs1 `unionLists` fs2)
985
       (True,False)  -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
Adam Gundry's avatar
Adam Gundry committed
986
                                   (fs1 `unionLists` fs2)
987
       (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
Adam Gundry's avatar
Adam Gundry committed
988
                                   (fs1 `unionLists` fs2)
989
       (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
Adam Gundry's avatar
Adam Gundry committed
990
991
992
993
994
                                   (fs1 `unionLists` fs2)
plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)
  = AvailTC n1 ss1 (fs1 `unionLists` fs2)
plusAvail (AvailTC n1 [] fs1)  (AvailTC _ ss2 fs2)
  = AvailTC n1 ss2 (fs1 `unionLists` fs2)
995
996
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])

Adam Gundry's avatar
Adam Gundry committed
997
-- | trims an 'AvailInfo' to keep only a single name
998
trimAvail :: AvailInfo -> Name -> AvailInfo
999
trimAvail (Avail b n)         _ = Avail b n
Adam Gundry's avatar
Adam Gundry committed
1000
1001
trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of
    Just x  -> AvailTC n [] [x]
Matthew Pickering's avatar
Matthew Pickering committed
1002
    Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []
1003
1004
1005
1006
1007
1008
1009
1010
1011

-- | filters 'AvailInfo's by the given predicate
filterAvails  :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
filterAvails keep avails = foldr (filterAvail keep) [] avails

-- | filters an 'AvailInfo' by the given predicate
filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
filterAvail keep ie rest =
  case ie of
1012
    Avail _ n | keep n    -> ie : rest
1013
            | otherwise -> rest