Module.hs 47.4 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The University of Glasgow, 2004-2006

sof's avatar
sof committed
4

5
Module
6
~~~~~~~~~~
7
Simply the name of a module, represented as a FastString.
8
These are Uniquable, hence we can build Maps with Modules as
9
the keys.
Austin Seipp's avatar
Austin Seipp committed
10
-}
sof's avatar
sof committed
11

niteria's avatar
niteria committed
12
{-# LANGUAGE RecordWildCards #-}
13
{-# LANGUAGE MultiParamTypeClasses #-}
dterei's avatar
dterei committed
14 15

module Module
sof's avatar
sof committed
16
    (
17 18 19 20 21 22
        -- * The ModuleName type
        ModuleName,
        pprModuleName,
        moduleNameFS,
        moduleNameString,
        moduleNameSlashes, moduleNameColons,
niteria's avatar
niteria committed
23
        moduleStableString,
Edward Z. Yang's avatar
Edward Z. Yang committed
24 25
        moduleFreeHoles,
        moduleIsDefinite,
26 27 28
        mkModuleName,
        mkModuleNameFS,
        stableModuleNameCmp,
Simon Marlow's avatar
Simon Marlow committed
29

30
        -- * The UnitId type
Edward Z. Yang's avatar
Edward Z. Yang committed
31 32
        ComponentId(..),
        UnitId(..),
33
        unitIdFS,
Edward Z. Yang's avatar
Edward Z. Yang committed
34 35
        unitIdKey,
        IndefUnitId(..),
36
        IndefModule(..),
37 38
        indefUnitIdToUnitId,
        indefModuleToModule,
39 40
        InstalledUnitId(..),
        toInstalledUnitId,
Edward Z. Yang's avatar
Edward Z. Yang committed
41 42 43
        ShHoleSubst,

        unitIdIsDefinite,
44
        unitIdString,
Edward Z. Yang's avatar
Edward Z. Yang committed
45 46 47 48 49 50 51 52
        unitIdFreeHoles,

        newUnitId,
        newIndefUnitId,
        newSimpleUnitId,
        hashUnitId,
        fsToUnitId,
        stringToUnitId,
53 54
        stableUnitIdCmp,

Edward Z. Yang's avatar
Edward Z. Yang committed
55 56 57 58 59 60 61 62 63 64
        -- * HOLE renaming
        renameHoleUnitId,
        renameHoleModule,
        renameHoleUnitId',
        renameHoleModule',

        -- * Generalization
        splitModuleInsts,
        splitUnitIdInsts,
        generalizeIndefUnitId,
65
        generalizeIndefModule,
Edward Z. Yang's avatar
Edward Z. Yang committed
66 67 68 69 70 71 72 73

        -- * Parsers
        parseModuleName,
        parseUnitId,
        parseComponentId,
        parseModuleId,
        parseModSubst,

74
        -- * Wired-in UnitIds
dterei's avatar
dterei committed
75
        -- $wired_in_packages
76 77 78 79 80 81 82
        primUnitId,
        integerUnitId,
        baseUnitId,
        rtsUnitId,
        thUnitId,
        mainUnitId,
        thisGhcUnitId,
Edward Z. Yang's avatar
Edward Z. Yang committed
83
        isHoleModule,
84 85
        interactiveUnitId, isInteractiveModule,
        wiredInUnitIds,
dterei's avatar
dterei committed
86 87

        -- * The Module type
Joel Burget's avatar
Joel Burget committed
88
        Module(Module),
89
        moduleUnitId, moduleName,
dterei's avatar
dterei committed
90 91
        pprModule,
        mkModule,
Edward Z. Yang's avatar
Edward Z. Yang committed
92
        mkHoleModule,
93
        stableModuleCmp,
94 95
        HasModule(..),
        ContainsModule(..),
Simon Marlow's avatar
Simon Marlow committed
96

97 98 99 100 101 102 103
        -- * Installed unit ids and modules
        InstalledModule(..),
        InstalledModuleEnv,
        installedModuleEq,
        installedUnitIdEq,
        installedUnitIdString,
        fsToInstalledUnitId,
104
        componentIdToInstalledUnitId,
105 106 107 108 109 110 111
        stringToInstalledUnitId,
        emptyInstalledModuleEnv,
        lookupInstalledModuleEnv,
        extendInstalledModuleEnv,
        filterInstalledModuleEnv,
        delInstalledModuleEnv,
        DefUnitId(..),
Edward Z. Yang's avatar
Edward Z. Yang committed
112

dterei's avatar
dterei committed
113 114 115 116 117 118 119 120 121 122 123
        -- * The ModuleLocation type
        ModLocation(..),
        addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,

        -- * Module mappings
        ModuleEnv,
        elemModuleEnv, extendModuleEnv, extendModuleEnvList,
        extendModuleEnvList_C, plusModuleEnv_C,
        delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,
        lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,
        moduleEnvKeys, moduleEnvElts, moduleEnvToList,
124
        unitModuleEnv, isEmptyModuleEnv,
niteria's avatar
niteria committed
125
        extendModuleEnvWith, filterModuleEnv,
Simon Marlow's avatar
Simon Marlow committed
126

dterei's avatar
dterei committed
127
        -- * ModuleName mappings
niteria's avatar
niteria committed
128
        ModuleNameEnv, DModuleNameEnv,
Simon Marlow's avatar
Simon Marlow committed
129

dterei's avatar
dterei committed
130
        -- * Sets of Modules
Austin Seipp's avatar
Austin Seipp committed
131
        ModuleSet,
132
        emptyModuleSet, mkModuleSet, moduleSetElts,
133
        extendModuleSet, extendModuleSetList, delModuleSet,
134 135
        elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet,
        unitModuleSet
sof's avatar
sof committed
136 137
    ) where

138 139
import GhcPrelude

140
import Config
sof's avatar
sof committed
141
import Outputable
Simon Marlow's avatar
Simon Marlow committed
142
import Unique
143
import UniqFM
niteria's avatar
niteria committed
144
import UniqDFM
Edward Z. Yang's avatar
Edward Z. Yang committed
145
import UniqDSet
146
import FastString
Simon Marlow's avatar
Simon Marlow committed
147
import Binary
148
import Util
149 150
import Data.List
import Data.Ord
Edward Z. Yang's avatar
Edward Z. Yang committed
151
import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..))
152
import Fingerprint
Edward Z. Yang's avatar
Edward Z. Yang committed
153 154 155 156 157 158 159 160

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.Char8
import Encoding

import qualified Text.ParserCombinators.ReadP as Parse
import Text.ParserCombinators.ReadP (ReadP, (<++))
import Data.Char (isAlphaNum)
161
import Control.DeepSeq
162
import Data.Coerce
163
import Data.Data
Edward Z. Yang's avatar
Edward Z. Yang committed
164
import Data.Function
165
import Data.Map (Map)
166
import Data.Set (Set)
167
import qualified Data.Map as Map
168
import qualified Data.Set as Set
169
import qualified FiniteMap as Map
170
import System.FilePath
sof's avatar
sof committed
171

Edward Z. Yang's avatar
Edward Z. Yang committed
172
import {-# SOURCE #-} DynFlags (DynFlags)
173
import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap, displayInstalledUnitId)
Edward Z. Yang's avatar
Edward Z. Yang committed
174

175 176
-- Note [The identifier lexicon]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Edward Z. Yang's avatar
Edward Z. Yang committed
177
-- Unit IDs, installed package IDs, ABI hashes, package names,
178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193
-- versions, there are a *lot* of different identifiers for closely
-- related things.  What do they all mean? Here's what.  (See also
-- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Packages/Concepts )
--
-- THE IMPORTANT ONES
--
-- ComponentId: An opaque identifier provided by Cabal, which should
-- uniquely identify such things as the package name, the package
-- version, the name of the component, the hash of the source code
-- tarball, the selected Cabal flags, GHC flags, direct dependencies of
-- the component.  These are very similar to InstalledPackageId, but
-- an 'InstalledPackageId' implies that it identifies a package, while
-- a package may install multiple components with different
-- 'ComponentId's.
--      - Same as Distribution.Package.ComponentId
--
194
-- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names
Gabor Greif's avatar
Gabor Greif committed
195
-- (ModuleName) to Modules.  This is how the compiler identifies instantiated
196
-- components, and also is the main identifier by which GHC identifies things.
197 198 199 200 201 202 203 204 205
--      - When Backpack is not being used, UnitId = ComponentId.
--        this means a useful fiction for end-users is that there are
--        only ever ComponentIds, and some ComponentIds happen to have
--        more information (UnitIds).
--      - Same as Language.Haskell.TH.Syntax:PkgName, see
--          https://ghc.haskell.org/trac/ghc/ticket/10279
--      - The same as PackageKey in GHC 7.10 (we renamed it because
--        they don't necessarily identify packages anymore.)
--      - Same as -this-package-key/-package-name flags
206 207 208 209
--      - An InstalledUnitId corresponds to an actual package which
--        we have installed on disk.  It could be definite or indefinite,
--        but if it's indefinite, it has nothing instantiated (we
--        never install partially instantiated units.)
210
--
211 212
-- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how
-- the compiler identifies modules (e.g. a Name is a Module + OccName)
213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
--      - Same as Language.Haskell.TH.Syntax:Module
--
-- THE LESS IMPORTANT ONES
--
-- PackageName: The "name" field in a Cabal file, something like "lens".
--      - Same as Distribution.Package.PackageName
--      - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see
--          https://ghc.haskell.org/trac/ghc/ticket/10279
--      - DIFFERENT FROM -package-name flag
--      - DIFFERENT FROM the 'name' field in an installed package
--        information.  This field could more accurately be described
--        as a munged package name: when it's for the main library
--        it is the same as the package name, but if it's an internal
--        library it's a munged combination of the package name and
--        the component name.
--
-- LEGACY ONES
--
-- InstalledPackageId: This is what we used to call ComponentId.
-- It's a still pretty useful concept for packages that have only
-- one library; in that case the logical InstalledPackageId =
-- ComponentId.  Also, the Cabal nix-local-build continues to
-- compute an InstalledPackageId which is then forcibly used
-- for all components in a package.  This means that if a dependency
-- from one component in a package changes, the InstalledPackageId
-- changes: you don't get as fine-grained dependency tracking,
-- but it means your builds are hermetic.  Eventually, Cabal will
-- deal completely in components and we can get rid of this.
--
-- PackageKey: This is what we used to call UnitId.  We ditched
-- "Package" from the name when we realized that you might want to
-- assign different "PackageKeys" to components from the same package.
-- (For a brief, non-released period of time, we also called these
-- UnitKeys).

Austin Seipp's avatar
Austin Seipp committed
248 249 250
{-
************************************************************************
*                                                                      *
251
\subsection{Module locations}
Austin Seipp's avatar
Austin Seipp committed
252 253 254
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
255

256 257 258
-- | Module Location
--
-- Where a module lives on the file system: the actual locations
batterseapower's avatar
batterseapower committed
259
-- of the .hs, .hi and .o files, if we have them
260 261 262
data ModLocation
   = ModLocation {
        ml_hs_file   :: Maybe FilePath,
dterei's avatar
dterei committed
263 264
                -- The source file, if we have one.  Package modules
                -- probably don't have source files.
265 266

        ml_hi_file   :: FilePath,
dterei's avatar
dterei committed
267 268 269
                -- Where the .hi file is, whether or not it exists
                -- yet.  Always of form foo.hi, even if there is an
                -- hi-boot file (we add the -boot suffix later)
270 271

        ml_obj_file  :: FilePath
dterei's avatar
dterei committed
272 273 274 275
                -- Where the .o file is, whether or not it exists yet.
                -- (might not exist either because the module hasn't
                -- been compiled yet, or because it is part of a
                -- package with a .a file)
276
  } deriving Show
277 278 279

instance Outputable ModLocation where
   ppr = text . show
sof's avatar
sof committed
280

Austin Seipp's avatar
Austin Seipp committed
281
{-
282
For a module in another package, the hs_file and obj_file
dterei's avatar
dterei committed
283
components of ModLocation are undefined.
284 285 286 287 288

The locations specified by a ModLocation may or may not
correspond to actual files yet: for example, even if the object
file doesn't exist, the ModLocation still contains the path to
where the object file will reside if/when it is created.
Austin Seipp's avatar
Austin Seipp committed
289
-}
290

291
addBootSuffix :: FilePath -> FilePath
batterseapower's avatar
batterseapower committed
292
-- ^ Add the @-boot@ suffix to .hs, .hi and .o files
293 294 295
addBootSuffix path = path ++ "-boot"

addBootSuffix_maybe :: Bool -> FilePath -> FilePath
batterseapower's avatar
batterseapower committed
296
-- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@
297 298 299 300 301
addBootSuffix_maybe is_boot path
 | is_boot   = addBootSuffix path
 | otherwise = path

addBootSuffixLocn :: ModLocation -> ModLocation
batterseapower's avatar
batterseapower committed
302
-- ^ Add the @-boot@ suffix to all file paths associated with the module
303 304
addBootSuffixLocn locn
  = locn { ml_hs_file  = fmap addBootSuffix (ml_hs_file locn)
dterei's avatar
dterei committed
305 306
         , ml_hi_file  = addBootSuffix (ml_hi_file locn)
         , ml_obj_file = addBootSuffix (ml_obj_file locn) }
sof's avatar
sof committed
307

Austin Seipp's avatar
Austin Seipp committed
308 309 310
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
311
\subsection{The name of a module}
Austin Seipp's avatar
Austin Seipp committed
312 313 314
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
315

batterseapower's avatar
batterseapower committed
316
-- | A ModuleName is essentially a simple string, e.g. @Data.List@.
Simon Marlow's avatar
Simon Marlow committed
317
newtype ModuleName = ModuleName FastString
318

Simon Marlow's avatar
Simon Marlow committed
319 320
instance Uniquable ModuleName where
  getUnique (ModuleName nm) = getUnique nm
321

Simon Marlow's avatar
Simon Marlow committed
322
instance Eq ModuleName where
323 324
  nm1 == nm2 = getUnique nm1 == getUnique nm2

Simon Marlow's avatar
Simon Marlow committed
325
instance Ord ModuleName where
326
  nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2
327

Simon Marlow's avatar
Simon Marlow committed
328 329
instance Outputable ModuleName where
  ppr = pprModuleName
sof's avatar
sof committed
330

Simon Marlow's avatar
Simon Marlow committed
331 332 333 334
instance Binary ModuleName where
  put_ bh (ModuleName fs) = put_ bh fs
  get bh = do fs <- get bh; return (ModuleName fs)

335 336 337 338
instance BinaryStringRep ModuleName where
  fromStringRep = mkModuleNameFS . mkFastStringByteString
  toStringRep   = fastStringToByteString . moduleNameFS

339 340 341 342 343 344
instance Data ModuleName where
  -- don't traverse?
  toConstr _   = abstractConstr "ModuleName"
  gunfold _ _  = error "gunfold"
  dataTypeOf _ = mkNoRepType "ModuleName"

345 346 347
instance NFData ModuleName where
  rnf x = x `seq` ()

348
stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering
batterseapower's avatar
batterseapower committed
349
-- ^ Compares module names lexically, rather than by their 'Unique's
350 351
stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2

Simon Marlow's avatar
Simon Marlow committed
352
pprModuleName :: ModuleName -> SDoc
dterei's avatar
dterei committed
353
pprModuleName (ModuleName nm) =
354
    getPprStyle $ \ sty ->
dterei's avatar
dterei committed
355
    if codeStyle sty
Ian Lynagh's avatar
Ian Lynagh committed
356
        then ztext (zEncodeFS nm)
dterei's avatar
dterei committed
357
        else ftext nm
358

Simon Marlow's avatar
Simon Marlow committed
359 360
moduleNameFS :: ModuleName -> FastString
moduleNameFS (ModuleName mod) = mod
361

Simon Marlow's avatar
Simon Marlow committed
362 363
moduleNameString :: ModuleName -> String
moduleNameString (ModuleName mod) = unpackFS mod
364

niteria's avatar
niteria committed
365 366 367 368 369
-- | Get a string representation of a 'Module' that's unique and stable
-- across recompilations.
-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal"
moduleStableString :: Module -> String
moduleStableString Module{..} =
370
  "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName
niteria's avatar
niteria committed
371

Simon Marlow's avatar
Simon Marlow committed
372 373
mkModuleName :: String -> ModuleName
mkModuleName s = ModuleName (mkFastString s)
374

Simon Marlow's avatar
Simon Marlow committed
375 376
mkModuleNameFS :: FastString -> ModuleName
mkModuleNameFS s = ModuleName s
377

378 379
-- |Returns the string version of the module name, with dots replaced by slashes.
--
380 381
moduleNameSlashes :: ModuleName -> String
moduleNameSlashes = dots_to_slashes . moduleNameString
382
  where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)
383

Edward Z. Yang's avatar
Edward Z. Yang committed
384
-- |Returns the string version of the module name, with dots replaced by colons.
385 386 387 388
--
moduleNameColons :: ModuleName -> String
moduleNameColons = dots_to_colons . moduleNameString
  where dots_to_colons = map (\c -> if c == '.' then ':' else c)
Simon Marlow's avatar
Simon Marlow committed
389

Austin Seipp's avatar
Austin Seipp committed
390 391 392
{-
************************************************************************
*                                                                      *
Simon Marlow's avatar
Simon Marlow committed
393
\subsection{A fully qualified module}
Austin Seipp's avatar
Austin Seipp committed
394 395 396
*                                                                      *
************************************************************************
-}
Simon Marlow's avatar
Simon Marlow committed
397

398
-- | A Module is a pair of a 'UnitId' and a 'ModuleName'.
Edward Z. Yang's avatar
Edward Z. Yang committed
399 400 401 402 403 404
--
-- Module variables (i.e. @<H>@) which can be instantiated to a
-- specific module at some later point in time are represented
-- with 'moduleUnitId' set to 'holeUnitId' (this allows us to
-- avoid having to make 'moduleUnitId' a partial operation.)
--
Simon Marlow's avatar
Simon Marlow committed
405
data Module = Module {
406
   moduleUnitId :: !UnitId,  -- pkg-1.0
407
   moduleName :: !ModuleName  -- A.B.C
Simon Marlow's avatar
Simon Marlow committed
408
  }
409
  deriving (Eq, Ord)
Simon Marlow's avatar
Simon Marlow committed
410

Edward Z. Yang's avatar
Edward Z. Yang committed
411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430
-- | Calculate the free holes of a 'Module'.  If this set is non-empty,
-- this module was defined in an indefinite library that had required
-- signatures.
--
-- If a module has free holes, that means that substitutions can operate on it;
-- if it has no free holes, substituting over a module has no effect.
moduleFreeHoles :: Module -> UniqDSet ModuleName
moduleFreeHoles m
    | isHoleModule m = unitUniqDSet (moduleName m)
    | otherwise = unitIdFreeHoles (moduleUnitId m)

-- | A 'Module' is definite if it has no free holes.
moduleIsDefinite :: Module -> Bool
moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles

-- | Create a module variable at some 'ModuleName'.
-- See Note [Representation of module/name variables]
mkHoleModule :: ModuleName -> Module
mkHoleModule = mkModule holeUnitId

batterseapower's avatar
batterseapower committed
431
instance Uniquable Module where
432
  getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n)
batterseapower's avatar
batterseapower committed
433

Simon Marlow's avatar
Simon Marlow committed
434 435 436 437 438 439 440
instance Outputable Module where
  ppr = pprModule

instance Binary Module where
  put_ bh (Module p n) = put_ bh p >> put_ bh n
  get bh = do p <- get bh; n <- get bh; return (Module p n)

441 442 443 444 445 446
instance Data Module where
  -- don't traverse?
  toConstr _   = abstractConstr "Module"
  gunfold _ _  = error "gunfold"
  dataTypeOf _ = mkNoRepType "Module"

447 448 449
instance NFData Module where
  rnf x = x `seq` ()

batterseapower's avatar
batterseapower committed
450 451
-- | This gives a stable ordering, as opposed to the Ord instance which
-- gives an ordering based on the 'Unique's of the components, which may
452 453
-- not be stable from run to run of the compiler.
stableModuleCmp :: Module -> Module -> Ordering
dterei's avatar
dterei committed
454
stableModuleCmp (Module p1 n1) (Module p2 n2)
455
   = (p1 `stableUnitIdCmp`  p2) `thenCmp`
456
     (n1 `stableModuleNameCmp` n2)
457

458
mkModule :: UnitId -> ModuleName -> Module
Simon Marlow's avatar
Simon Marlow committed
459 460 461
mkModule = Module

pprModule :: Module -> SDoc
Edward Z. Yang's avatar
Edward Z. Yang committed
462
pprModule mod@(Module p n)  = getPprStyle doc
Simon Marlow's avatar
Simon Marlow committed
463
 where
Edward Z. Yang's avatar
Edward Z. Yang committed
464 465 466
  doc sty
    | codeStyle sty =
        (if p == mainUnitId
Simon Marlow's avatar
Simon Marlow committed
467
                then empty -- never qualify the main package in code
Edward Z. Yang's avatar
Edward Z. Yang committed
468 469 470 471 472 473 474 475
                else ztext (zEncodeFS (unitIdFS p)) <> char '_')
            <> pprModuleName n
    | qualModule sty mod =
        if isHoleModule mod
            then angleBrackets (pprModuleName n)
            else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n
    | otherwise =
        pprModuleName n
476 477 478 479 480 481

class ContainsModule t where
    extractModule :: t -> Module

class HasModule m where
    getModule :: m Module
482

483 484 485 486 487
instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where
  fromDbModule (DbModule uid mod_name)  = mkModule uid mod_name
  fromDbModule (DbModuleVar mod_name)   = mkHoleModule mod_name
  fromDbUnitId (DbUnitId cid insts)     = newUnitId cid insts
  fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid)
Edward Z. Yang's avatar
Edward Z. Yang committed
488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523
  -- GHC never writes to the database, so it's not needed
  toDbModule = error "toDbModule: not implemented"
  toDbUnitId = error "toDbUnitId: not implemented"

{-
************************************************************************
*                                                                      *
\subsection{ComponentId}
*                                                                      *
************************************************************************
-}

-- | A 'ComponentId' consists of the package name, package version, component
-- ID, the transitive dependencies of the component, and other information to
-- uniquely identify the source code and build configuration of a component.
--
-- This used to be known as an 'InstalledPackageId', but a package can contain
-- multiple components and a 'ComponentId' uniquely identifies a component
-- within a package.  When a package only has one component, the 'ComponentId'
-- coincides with the 'InstalledPackageId'
newtype ComponentId        = ComponentId        FastString deriving (Eq, Ord)

instance BinaryStringRep ComponentId where
  fromStringRep = ComponentId . mkFastStringByteString
  toStringRep (ComponentId s) = fastStringToByteString s

instance Uniquable ComponentId where
  getUnique (ComponentId n) = getUnique n

instance Outputable ComponentId where
  ppr cid@(ComponentId fs) =
    getPprStyle $ \sty ->
    sdocWithDynFlags $ \dflags ->
      case componentIdString dflags cid of
        Just str | not (debugStyle sty) -> text str
        _ -> ftext fs
524

Austin Seipp's avatar
Austin Seipp committed
525 526 527
{-
************************************************************************
*                                                                      *
528
\subsection{UnitId}
Austin Seipp's avatar
Austin Seipp committed
529 530 531
*                                                                      *
************************************************************************
-}
532

533 534 535 536 537 538 539 540 541 542 543 544 545
-- | A unit identifier identifies a (possibly partially) instantiated
-- library.  It is primarily used as part of 'Module', which in turn
-- is used in 'Name', which is used to give names to entities when
-- typechecking.
--
-- There are two possible forms for a 'UnitId'.  It can be a
-- 'DefiniteUnitId', in which case we just have a string that uniquely
-- identifies some fully compiled, installed library we have on disk.
-- However, when we are typechecking a library with missing holes,
-- we may need to instantiate a library on the fly (in which case
-- we don't have any on-disk representation.)  In that case, you
-- have an 'IndefiniteUnitId', which explicitly records the
-- instantiation, so that we can substitute over it.
Edward Z. Yang's avatar
Edward Z. Yang committed
546
data UnitId
547 548
    = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId
    |   DefiniteUnitId {-# UNPACK #-} !DefUnitId
Edward Z. Yang's avatar
Edward Z. Yang committed
549 550

unitIdFS :: UnitId -> FastString
551 552
unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x
unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x
Edward Z. Yang's avatar
Edward Z. Yang committed
553 554

unitIdKey :: UnitId -> Unique
555 556
unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x
unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x
Edward Z. Yang's avatar
Edward Z. Yang committed
557

558 559 560 561 562
-- | A unit identifier which identifies an indefinite
-- library (with holes) that has been *on-the-fly* instantiated
-- with a substitution 'indefUnitIdInsts'.  In fact, an indefinite
-- unit identifier could have no holes, but we haven't gotten
-- around to compiling the actual library yet.
Edward Z. Yang's avatar
Edward Z. Yang committed
563
--
564
-- An indefinite unit identifier pretty-prints to something like
Edward Z. Yang's avatar
Edward Z. Yang committed
565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585
-- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the
-- brackets enclose the module substitution).
data IndefUnitId
    = IndefUnitId {
        -- | A private, uniquely identifying representation of
        -- a UnitId.  This string is completely private to GHC
        -- and is just used to get a unique; in particular, we don't use it for
        -- symbols (indefinite libraries are not compiled).
        indefUnitIdFS :: FastString,
        -- | Cached unique of 'unitIdFS'.
        indefUnitIdKey :: Unique,
        -- | The component identity of the indefinite library that
        -- is being instantiated.
        indefUnitIdComponentId :: !ComponentId,
        -- | The sorted (by 'ModuleName') instantiations of this library.
        indefUnitIdInsts :: ![(ModuleName, Module)],
        -- | A cache of the free module variables of 'unitIdInsts'.
        -- This lets us efficiently tell if a 'UnitId' has been
        -- fully instantiated (free module variables are empty)
        -- and whether or not a substitution can have any effect.
        indefUnitIdFreeHoles :: UniqDSet ModuleName
Ryan Scott's avatar
Ryan Scott committed
586
    }
Edward Z. Yang's avatar
Edward Z. Yang committed
587

588 589 590 591 592 593
instance Eq IndefUnitId where
  u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2

instance Ord IndefUnitId where
  u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2

594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623
instance Binary IndefUnitId where
  put_ bh indef = do
    put_ bh (indefUnitIdComponentId indef)
    put_ bh (indefUnitIdInsts indef)
  get bh = do
    cid   <- get bh
    insts <- get bh
    let fs = hashUnitId cid insts
    return IndefUnitId {
            indefUnitIdComponentId = cid,
            indefUnitIdInsts = insts,
            indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
            indefUnitIdFS = fs,
            indefUnitIdKey = getUnique fs
           }

-- | Create a new 'IndefUnitId' given an explicit module substitution.
newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId
newIndefUnitId cid insts =
    IndefUnitId {
        indefUnitIdComponentId = cid,
        indefUnitIdInsts = sorted_insts,
        indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
        indefUnitIdFS = fs,
        indefUnitIdKey = getUnique fs
    }
  where
     fs = hashUnitId cid sorted_insts
     sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts

624 625 626 627 628 629 630 631 632 633 634 635 636 637
-- | Injects an 'IndefUnitId' (indefinite library which
-- was on-the-fly instantiated) to a 'UnitId' (either
-- an indefinite or definite library).
indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId
indefUnitIdToUnitId dflags iuid =
    -- NB: suppose that we want to compare the indefinite
    -- unit id p[H=impl:H] against p+abcd (where p+abcd
    -- happens to be the existing, installed version of
    -- p[H=impl:H].  If we *only* wrap in p[H=impl:H]
    -- IndefiniteUnitId, they won't compare equal; only
    -- after improvement will the equality hold.
    improveUnitId (getPackageConfigMap dflags) $
        IndefiniteUnitId iuid

638 639 640
data IndefModule = IndefModule {
        indefModuleUnitId :: IndefUnitId,
        indefModuleName   :: ModuleName
Ryan Scott's avatar
Ryan Scott committed
641
    } deriving (Eq, Ord)
642 643 644 645 646

instance Outputable IndefModule where
  ppr (IndefModule uid m) =
    ppr uid <> char ':' <> ppr m

647 648 649 650 651 652
-- | Injects an 'IndefModule' to 'Module' (see also
-- 'indefUnitIdToUnitId'.
indefModuleToModule :: DynFlags -> IndefModule -> Module
indefModuleToModule dflags (IndefModule iuid mod_name) =
    mkModule (indefUnitIdToUnitId dflags iuid) mod_name

653 654 655 656 657 658 659
-- | An installed unit identifier identifies a library which has
-- been installed to the package database.  These strings are
-- provided to us via the @-this-unit-id@ flag.  The library
-- in question may be definite or indefinite; if it is indefinite,
-- none of the holes have been filled (we never install partially
-- instantiated libraries.)  Put another way, an installed unit id
-- is either fully instantiated, or not instantiated at all.
Edward Z. Yang's avatar
Edward Z. Yang committed
660
--
661 662
-- Installed unit identifiers look something like @p+af23SAj2dZ219@,
-- or maybe just @p@ if they don't use Backpack.
663
newtype InstalledUnitId =
664
    InstalledUnitId {
Edward Z. Yang's avatar
Edward Z. Yang committed
665 666
      -- | The full hashed unit identifier, including the component id
      -- and the hash.
667
      installedUnitIdFS :: FastString
Edward Z. Yang's avatar
Edward Z. Yang committed
668 669
    }

670
instance Binary InstalledUnitId where
671 672
  put_ bh (InstalledUnitId fs) = put_ bh fs
  get bh = do fs <- get bh; return (InstalledUnitId fs)
Edward Z. Yang's avatar
Edward Z. Yang committed
673

674
instance BinaryStringRep InstalledUnitId where
675
  fromStringRep bs = InstalledUnitId (mkFastStringByteString bs)
676 677 678 679 680 681 682 683 684 685 686 687 688
  -- GHC doesn't write to database
  toStringRep   = error "BinaryStringRep InstalledUnitId: not implemented"

instance Eq InstalledUnitId where
    uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2

instance Ord InstalledUnitId where
    u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2

instance Uniquable InstalledUnitId where
    getUnique = installedUnitIdKey

instance Outputable InstalledUnitId where
689 690 691 692 693 694 695 696 697
    ppr uid@(InstalledUnitId fs) =
        getPprStyle $ \sty ->
        sdocWithDynFlags $ \dflags ->
          case displayInstalledUnitId dflags uid of
            Just str | not (debugStyle sty) -> text str
            _ -> ftext fs

installedUnitIdKey :: InstalledUnitId -> Unique
installedUnitIdKey = getUnique . installedUnitIdFS
698 699 700 701 702

-- | Lossy conversion to the on-disk 'InstalledUnitId' for a component.
toInstalledUnitId :: UnitId -> InstalledUnitId
toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid
toInstalledUnitId (IndefiniteUnitId indef) =
703
    componentIdToInstalledUnitId (indefUnitIdComponentId indef)
704 705 706

installedUnitIdString :: InstalledUnitId -> String
installedUnitIdString = unpackFS . installedUnitIdFS
Edward Z. Yang's avatar
Edward Z. Yang committed
707 708 709 710 711 712 713

instance Outputable IndefUnitId where
    ppr uid =
      -- getPprStyle $ \sty ->
      ppr cid <>
        (if not (null insts) -- pprIf
          then
714
            brackets (hcat
Edward Z. Yang's avatar
Edward Z. Yang committed
715 716
                (punctuate comma $
                    [ ppr modname <> text "=" <> ppr m
717
                    | (modname, m) <- insts]))
Edward Z. Yang's avatar
Edward Z. Yang committed
718 719 720 721 722
          else empty)
     where
      cid   = indefUnitIdComponentId uid
      insts = indefUnitIdInsts uid

723 724 725 726 727 728
-- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'.
data InstalledModule = InstalledModule {
   installedModuleUnitId :: !InstalledUnitId,
   installedModuleName :: !ModuleName
  }
  deriving (Eq, Ord)
Edward Z. Yang's avatar
Edward Z. Yang committed
729

730 731 732 733 734
instance Outputable InstalledModule where
  ppr (InstalledModule p n) =
    ppr p <> char ':' <> pprModuleName n

fsToInstalledUnitId :: FastString -> InstalledUnitId
735 736 737 738
fsToInstalledUnitId fs = InstalledUnitId fs

componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId
componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs
739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754

stringToInstalledUnitId :: String -> InstalledUnitId
stringToInstalledUnitId = fsToInstalledUnitId . mkFastString

-- | Test if a 'Module' corresponds to a given 'InstalledModule',
-- modulo instantiation.
installedModuleEq :: InstalledModule -> Module -> Bool
installedModuleEq imod mod =
    fst (splitModuleInsts mod) == imod

-- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId',
-- modulo instantiation.
installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool
installedUnitIdEq iuid uid =
    fst (splitUnitIdInsts uid) == iuid

755 756 757 758
-- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that
-- it only refers to a definite library; i.e., one we have generated
-- code for.
newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId }
Ryan Scott's avatar
Ryan Scott committed
759
    deriving (Eq, Ord)
760 761 762 763 764 765 766 767

instance Outputable DefUnitId where
    ppr (DefUnitId uid) = ppr uid

instance Binary DefUnitId where
    put_ bh (DefUnitId uid) = put_ bh uid
    get bh = do uid <- get bh; return (DefUnitId uid)

768 769 770 771 772
-- | A map keyed off of 'InstalledModule'
newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt)

emptyInstalledModuleEnv :: InstalledModuleEnv a
emptyInstalledModuleEnv = InstalledModuleEnv Map.empty
Edward Z. Yang's avatar
Edward Z. Yang committed
773

774 775
lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a
lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e
Edward Z. Yang's avatar
Edward Z. Yang committed
776

777 778
extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a
extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e)
Edward Z. Yang's avatar
Edward Z. Yang committed
779

780 781 782 783 784 785
filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a
filterInstalledModuleEnv f (InstalledModuleEnv e) =
  InstalledModuleEnv (Map.filterWithKey f e)

delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a
delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e)
Edward Z. Yang's avatar
Edward Z. Yang committed
786

787
-- Note [UnitId to InstalledUnitId improvement]
Edward Z. Yang's avatar
Edward Z. Yang committed
788 789
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Just because a UnitId is definite (has no holes) doesn't
790
-- mean it's necessarily a InstalledUnitId; it could just be
Edward Z. Yang's avatar
Edward Z. Yang committed
791 792 793 794 795 796 797 798 799 800 801 802
-- that over the course of renaming UnitIds on the fly
-- while typechecking an indefinite library, we
-- ended up with a fully instantiated unit id with no hash,
-- since we haven't built it yet.  This is fine.
--
-- However, if there is a hashed unit id for this instantiation
-- in the package database, we *better use it*, because
-- that hashed unit id may be lurking in another interface,
-- and chaos will ensue if we attempt to compare the two
-- (the unitIdFS for a UnitId never corresponds to a Cabal-provided
-- hash of a compiled instantiated library).
--
803 804 805 806 807 808 809
-- There is one last niggle: improvement based on the package database means
-- that we might end up developing on a package that is not transitively
-- depended upon by the packages the user specified directly via command line
-- flags.  This could lead to strange and difficult to understand bugs if those
-- instantiations are out of date.  The solution is to only improve a
-- unit id if the new unit id is part of the 'preloadClosure'; i.e., the
-- closure of all the packages which were explicitly specified.
Edward Z. Yang's avatar
Edward Z. Yang committed
810 811 812

-- | Retrieve the set of free holes of a 'UnitId'.
unitIdFreeHoles :: UnitId -> UniqDSet ModuleName
813
unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x
Edward Z. Yang's avatar
Edward Z. Yang committed
814
-- Hashed unit ids are always fully instantiated
815
unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet
Edward Z. Yang's avatar
Edward Z. Yang committed
816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834

instance Show UnitId where
    show = unitIdString

-- | A 'UnitId' is definite if it has no free holes.
unitIdIsDefinite :: UnitId -> Bool
unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles

-- | Generate a uniquely identifying 'FastString' for a unit
-- identifier.  This is a one-way function.  You can rely on one special
-- property: if a unit identifier is in most general form, its 'FastString'
-- coincides with its 'ComponentId'.  This hash is completely internal
-- to GHC and is not used for symbol names or file paths.
hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString
hashUnitId cid sorted_holes =
    mkFastStringByteString
  . fingerprintUnitId (toStringRep cid)
  $ rawHashUnitId sorted_holes

835
-- | Generate a hash for a sorted module substitution.
Edward Z. Yang's avatar
Edward Z. Yang committed
836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855
rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint
rawHashUnitId sorted_holes =
    fingerprintByteString
  . BS.concat $ do
        (m, b) <- sorted_holes
        [ toStringRep m,                BS.Char8.singleton ' ',
          fastStringToByteString (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':',
          toStringRep (moduleName b),   BS.Char8.singleton '\n']

fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString
fingerprintUnitId prefix (Fingerprint a b)
    = BS.concat
    $ [ prefix
      , BS.Char8.singleton '-'
      , BS.Char8.pack (toBase62Padded a)
      , BS.Char8.pack (toBase62Padded b) ]

-- | Create a new, un-hashed unit identifier.
newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId
newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug...
856
newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts
Edward Z. Yang's avatar
Edward Z. Yang committed
857 858

pprUnitId :: UnitId -> SDoc
859 860
pprUnitId (DefiniteUnitId uid) = ppr uid
pprUnitId (IndefiniteUnitId uid) = ppr uid
Edward Z. Yang's avatar
Edward Z. Yang committed
861 862 863

instance Eq UnitId where
  uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2
864

865
instance Uniquable UnitId where
Edward Z. Yang's avatar
Edward Z. Yang committed
866
  getUnique = unitIdKey
867

868
instance Ord UnitId where
869
  nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2
870

871
instance Data UnitId where
872
  -- don't traverse?
873
  toConstr _   = abstractConstr "UnitId"
874
  gunfold _ _  = error "gunfold"
875
  dataTypeOf _ = mkNoRepType "UnitId"
876

877 878 879
instance NFData UnitId where
  rnf x = x `seq` ()

880
stableUnitIdCmp :: UnitId -> UnitId -> Ordering
batterseapower's avatar
batterseapower committed
881
-- ^ Compares package ids lexically, rather than by their 'Unique's
882
stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2
883

884
instance Outputable UnitId where
Edward Z. Yang's avatar
Edward Z. Yang committed
885
   ppr pk = pprUnitId pk
886

Edward Z. Yang's avatar
Edward Z. Yang committed
887
-- Performance: would prefer to have a NameCache like thing
888
instance Binary UnitId where
889 890 891 892
  put_ bh (DefiniteUnitId def_uid) = do
    putByte bh 0
    put_ bh def_uid
  put_ bh (IndefiniteUnitId indef_uid) = do
Edward Z. Yang's avatar
Edward Z. Yang committed
893
    putByte bh 1
894
    put_ bh indef_uid
Edward Z. Yang's avatar
Edward Z. Yang committed
895 896
  get bh = do b <- getByte bh
              case b of
897 898
                0 -> fmap DefiniteUnitId   (get bh)
                _ -> fmap IndefiniteUnitId (get bh)
899

Edward Z. Yang's avatar
Edward Z. Yang committed
900 901 902
instance Binary ComponentId where
  put_ bh (ComponentId fs) = put_ bh fs
  get bh = do { fs <- get bh; return (ComponentId fs) }
903

Edward Z. Yang's avatar
Edward Z. Yang committed
904 905 906 907 908 909 910
-- | Create a new simple unit identifier (no holes) from a 'ComponentId'.
newSimpleUnitId :: ComponentId -> UnitId
newSimpleUnitId (ComponentId fs) = fsToUnitId fs

-- | Create a new simple unit identifier from a 'FastString'.  Internally,
-- this is primarily used to specify wired-in unit identifiers.
fsToUnitId :: FastString -> UnitId
911
fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId
912

913 914
stringToUnitId :: String -> UnitId
stringToUnitId = fsToUnitId . mkFastString
915

916 917
unitIdString :: UnitId -> String
unitIdString = unpackFS . unitIdFS
918

Edward Z. Yang's avatar
Edward Z. Yang committed
919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960
{-
************************************************************************
*                                                                      *
                        Hole substitutions
*                                                                      *
************************************************************************
-}

-- | Substitution on module variables, mapping module names to module
-- identifiers.
type ShHoleSubst = ModuleNameEnv Module

-- | Substitutes holes in a 'Module'.  NOT suitable for being called
-- directly on a 'nameModule', see Note [Representation of module/name variable].
-- @p[A=<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@;
-- similarly, @<A>@ maps to @q():A@.
renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module
renameHoleModule dflags = renameHoleModule' (getPackageConfigMap dflags)

-- | Substitutes holes in a 'UnitId', suitable for renaming when
-- an include occurs; see Note [Representation of module/name variable].
--
-- @p[A=<A>]@ maps to @p[A=<B>]@ with @A=<B>@.
renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId
renameHoleUnitId dflags = renameHoleUnitId' (getPackageConfigMap dflags)

-- | Like 'renameHoleModule', but requires only 'PackageConfigMap'
-- so it can be used by "Packages".
renameHoleModule' :: PackageConfigMap -> ShHoleSubst -> Module -> Module
renameHoleModule' pkg_map env m
  | not (isHoleModule m) =
        let uid = renameHoleUnitId' pkg_map env (moduleUnitId m)
        in mkModule uid (moduleName m)
  | Just m' <- lookupUFM env (moduleName m) = m'
  -- NB m = <Blah>, that's what's in scope.
  | otherwise = m

-- | Like 'renameHoleUnitId, but requires only 'PackageConfigMap'
-- so it can be used by "Packages".
renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId
renameHoleUnitId' pkg_map env uid =
    case uid of
961
      (IndefiniteUnitId
Edward Z. Yang's avatar
Edward Z. Yang committed
962 963 964 965 966 967 968 969
        IndefUnitId{ indefUnitIdComponentId = cid
                   , indefUnitIdInsts       = insts
                   , indefUnitIdFreeHoles   = fh })
          -> if isNullUFM (intersectUFM_C const (udfmToUfm fh) env)
                then uid
                -- Functorially apply the substitution to the instantiation,
                -- then check the 'PackageConfigMap' to see if there is
                -- a compiled version of this 'UnitId' we can improve to.
970
                -- See Note [UnitId to InstalledUnitId] improvement
Edward Z. Yang's avatar
Edward Z. Yang committed
971 972 973 974 975 976 977 978 979
                else improveUnitId pkg_map $
                        newUnitId cid
                            (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts)
      _ -> uid

-- | Given a possibly on-the-fly instantiated module, split it into
-- a 'Module' that we definitely can find on-disk, as well as an
-- instantiation if we need to instantiate it on the fly.  If the
-- instantiation is @Nothing@ no on-the-fly renaming is needed.
980
splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule)
Edward Z. Yang's avatar
Edward Z. Yang committed
981
splitModuleInsts m =
982 983 984
    let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m)
    in (InstalledModule uid (moduleName m),
        fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid)
Edward Z. Yang's avatar
Edward Z. Yang committed
985 986

-- | See 'splitModuleInsts'.
987
splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId)
988
splitUnitIdInsts (IndefiniteUnitId iuid) =
989
    (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid)
990
splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing)
Edward Z. Yang's avatar
Edward Z. Yang committed
991 992 993 994 995 996

generalizeIndefUnitId :: IndefUnitId -> IndefUnitId
generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid
                                 , indefUnitIdInsts = insts } =
    newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts)

997 998 999
generalizeIndefModule :: IndefModule -> IndefModule
generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n

Edward Z. Yang's avatar
Edward Z. Yang committed
1000 1001 1002 1003 1004
parseModuleName :: ReadP ModuleName
parseModuleName = fmap mkModuleName
                $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.")

parseUnitId :: ReadP UnitId
1005
parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId
Edward Z. Yang's avatar
Edward Z. Yang committed
1006
  where
1007 1008 1009 1010 1011
    parseFullUnitId = do
        cid <- parseComponentId
        insts <- parseModSubst
        return (newUnitId cid insts)
    parseDefiniteUnitId = do
1012 1013
        s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")
        return (stringToUnitId s)
1014 1015 1016
    parseSimpleUnitId = do
        cid <- parseComponentId
        return (newSimpleUnitId cid)
Edward Z. Yang's avatar
Edward Z. Yang committed
1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043

parseComponentId :: ReadP ComponentId
parseComponentId = (ComponentId . mkFastString)  `fmap` Parse.munch1 abi_char
   where abi_char c = isAlphaNum c || c `elem` "-_."

parseModuleId :: ReadP Module
parseModuleId = parseModuleVar <++ parseModule
    where
      parseModuleVar = do
        _ <- Parse.char '<'
        modname <- parseModuleName
        _ <- Parse.char '>'
        return (mkHoleModule modname)
      parseModule = do
        uid <- parseUnitId
        _ <- Parse.char ':'
        modname <- parseModuleName
        return (mkModule uid modname)

parseModSubst :: ReadP [(ModuleName, Module)]
parseModSubst = Parse.between (Parse.char '[') (Parse.char ']')
      . flip Parse.sepBy (Parse.char ',')
      $ do k <- parseModuleName
           _ <- Parse.char '='
           v <- parseModuleId
           return (k, v)

1044 1045

-- -----------------------------------------------------------------------------
batterseapower's avatar
batterseapower committed
1046 1047
-- $wired_in_packages
-- Certain packages are known to the compiler, in that we know about certain
dterei's avatar
dterei committed
1048
-- entities that reside in these packages, and the compiler needs to
1049 1050 1051 1052 1053 1054 1055 1056
-- declare static Modules and Names that refer to these packages.  Hence
-- the wired-in packages can't include version numbers, since we don't want
-- to bake the version numbers of these packages into GHC.
--
-- So here's the plan.  Wired-in packages are still versioned as
-- normal in the packages database, and you can still have multiple
-- versions of them installed.  However, for each invocation of GHC,
-- only a single instance of each wired-in package will be recognised
Ian Lynagh's avatar
Ian Lynagh committed
1057
-- (the desired one is selected via @-package@\/@-hide-package@), and GHC
1058
-- will use the unversioned 'UnitId' below when referring to it,
1059 1060 1061
-- including in .hi files and object file symbols.  Unselected
-- versions of wired-in packages will be ignored, as will any other
-- package that depends directly or indirectly on it (much as if you
batterseapower's avatar
batterseapower committed
1062 1063 1064
-- had used @-ignore-package@).

-- Make sure you change 'Packages.findWiredInPackages' if you add an entry here
1065

1066 1067
integerUnitId, primUnitId,
  baseUnitId, rtsUnitId,
1068
  thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId  :: UnitId
1069 1070
primUnitId        = fsToUnitId (fsLit "ghc-prim")
integerUnitId     = fsToUnitId (fsLit n)
1071 1072 1073 1074
  where
    n = case cIntegerLibraryType of
        IntegerGMP    -> "integer-gmp"
        IntegerSimple -> "integer-simple"
1075 1076 1077 1078 1079
baseUnitId        = fsToUnitId (fsLit "base")
rtsUnitId         = fsToUnitId (fsLit "rts")
thUnitId          = fsToUnitId (fsLit "template-haskell")
thisGhcUnitId     = fsToUnitId (fsLit "ghc")
interactiveUnitId = fsToUnitId (fsLit "interactive")
1080

batterseapower's avatar
batterseapower committed
1081 1082 1083
-- | This is the package Id for the current program.  It is the default
-- package Id if you don't specify a package name.  We don't add this prefix
-- to symbol names, since there can be only one main package per program.
1084
mainUnitId      = fsToUnitId (fsLit "main")
1085

1086 1087
-- | This is a fake package id used to provide identities to any un-implemented
-- signatures.  The set of hole identities is global over an entire compilation.
Edward Z. Yang's avatar
Edward Z. Yang committed
1088 1089
-- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead.
-- See Note [Representation of module/name variables]
1090 1091
holeUnitId :: UnitId
holeUnitId      = fsToUnitId (fsLit "hole")
1092

1093
isInteractiveModule :: Module -> Bool
1094
isInteractiveModule mod = moduleUnitId mod == interactiveUnitId
1095

Edward Z. Yang's avatar
Edward Z. Yang committed
1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115
-- Note [Representation of module/name variables]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- In our ICFP'16, we use <A> to represent module holes, and {A.T} to represent
-- name holes.  This could have been represented by adding some new cases
-- to the core data types, but this would have made the existing 'nameModule'
-- and 'moduleUnitId' partial, which would have required a lot of modifications
-- to existing code.
--
-- Instead, we adopted the following encoding scheme:
--
--      <A>   ===> hole:A
--      {A.T} ===> hole:A.T
--
-- This encoding is quite convenient, but it is also a bit dangerous too,
-- because if you have a 'hole:A' you need to know if it's actually a
-- 'Module' or just a module stored in a 'Name'; these two cases must be
-- treated differently when doing substitutions.  'renameHoleModule'
-- and 'renameHoleUnitId' assume they are NOT operating on a
-- 'Name'; 'NameShape' handles name substitutions exclusively.

1116
isHoleModule :: Module -> Bool
1117 1118 1119 1120 1121 1122 1123 1124
isHoleModule mod = moduleUnitId mod == holeUnitId

wiredInUnitIds :: [UnitId]
wiredInUnitIds = [ primUnitId,
                       integerUnitId,
                       baseUnitId,
                       rtsUnitId,
                       thUnitId,
1125
                       thisGhcUnitId ]
1126

Austin Seipp's avatar
Austin Seipp committed
1127 1128 1129
{-
************************************************************************
*                                                                      *
1130
\subsection{@ModuleEnv@s}
Austin Seipp's avatar
Austin Seipp committed
1131 1132 1133
*                                                                      *
************************************************************************
-}
1134

batterseapower's avatar
batterseapower committed
1135
-- | A map keyed off of 'Module's
1136
newtype ModuleEnv elt = ModuleEnv (Map NDModule elt)
Edward Z. Yang's avatar
Edward Z. Yang committed
1137

1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160
{-
Note [ModuleEnv performance and determinism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To prevent accidental reintroduction of nondeterminism the Ord instance
for Module was changed to not depend on Unique ordering and to use the
lexicographic order. This is potentially expensive, but when measured
there was no difference in performance.

To be on the safe side and not pessimize ModuleEnv uses nondeterministic
ordering on Module and normalizes by doing the lexicographic sort when
turning the env to a list.
See Note [Unique Determinism] for more information about the source of
nondeterminismand and Note [Deterministic UniqFM] for explanation of why
it matters for maps.
-}

newtype NDModule = NDModule { unNDModule :: Module }
  deriving Eq
  -- A wrapper for Module with faster nondeterministic Ord.
  -- Don't export, See [ModuleEnv performance and determinism]

instance Ord NDModule where
  compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) =
niteria's avatar
niteria committed
1161 1162
    (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp`
    (getUnique n1 `nonDetCmpUnique` getUnique n2)
1163 1164

filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
1165 1166
filterModuleEnv f (ModuleEnv e) =
  ModuleEnv (Map.filterWithKey (f . unNDModule) e)
1167 1168

elemModuleEnv :: Module -> ModuleEnv a -> Bool
1169
elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e
1170 1171

extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a
1172
extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e)
1173

1174 1175 1176 1177
extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a
                    -> ModuleEnv a
extendModuleEnvWith f (ModuleEnv e) m x =
  ModuleEnv (Map.insertWith f (NDModule m) x e)
1178 1179

extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a
1180 1181
extendModuleEnvList (ModuleEnv e) xs =
  ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e)
1182 1183 1184

extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)]
                      -> ModuleEnv a
1185 1186
extendModuleEnvList_C f (ModuleEnv e) xs =
  ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e)
1187 1188

plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
1189 1190
plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) =
  ModuleEnv (Map.unionWith f e1 e2)
1191 1192

delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a
1193 1194
delModuleEnvList (ModuleEnv e) ms =
  ModuleEnv (Map.deleteList (map NDModule ms) e)
1195 1196

delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a
1197
delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e)
1198 1199

plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a
1200
plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2)
1201 1202

lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a
1203
lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e
1204

1205
lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a
1206 1207
lookupWithDefaultModuleEnv (ModuleEnv e) x m =
  Map.findWithDefault x (NDModule m) e
1208 1209

mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b
1210
mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e)
1211 1212

mkModuleEnv :: [(Module, a)] -> ModuleEnv a
1213
mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs])
1214 1215

emptyModuleEnv :: ModuleEnv a
1216
emptyModuleEnv = ModuleEnv Map.empty
1217 1218

moduleEnvKeys :: ModuleEnv a -> [Module]
1219 1220
moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e
  -- See Note [ModuleEnv performance and determinism]
1221 1222

moduleEnvElts :: ModuleEnv a -> [a]
1223 1224
moduleEnvElts e = map snd $ moduleEnvToList e
  -- See Note [ModuleEnv performance and determinism]