Add selectors for common fields (DataCon/PatSyn) to ConLike
[ghc.git] / compiler / basicTypes / Module.hs
1 {-
2 (c) The University of Glasgow, 2004-2006
3
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.
10 -}
11
12 {-# LANGUAGE DeriveDataTypeable #-}
13
14 module Module
15 (
16 -- * The ModuleName type
17 ModuleName,
18 pprModuleName,
19 moduleNameFS,
20 moduleNameString,
21 moduleNameSlashes, moduleNameColons,
22 mkModuleName,
23 mkModuleNameFS,
24 stableModuleNameCmp,
25
26 -- * The PackageKey type
27 PackageKey,
28 fsToPackageKey,
29 packageKeyFS,
30 stringToPackageKey,
31 packageKeyString,
32 stablePackageKeyCmp,
33
34 -- * Wired-in PackageKeys
35 -- $wired_in_packages
36 primPackageKey,
37 integerPackageKey,
38 basePackageKey,
39 rtsPackageKey,
40 thPackageKey,
41 dphSeqPackageKey,
42 dphParPackageKey,
43 mainPackageKey,
44 thisGhcPackageKey,
45 holePackageKey, isHoleModule,
46 interactivePackageKey, isInteractiveModule,
47 wiredInPackageKeys,
48
49 -- * The Module type
50 Module(Module),
51 modulePackageKey, moduleName,
52 pprModule,
53 mkModule,
54 stableModuleCmp,
55 HasModule(..),
56 ContainsModule(..),
57
58 -- * The ModuleLocation type
59 ModLocation(..),
60 addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,
61
62 -- * Module mappings
63 ModuleEnv,
64 elemModuleEnv, extendModuleEnv, extendModuleEnvList,
65 extendModuleEnvList_C, plusModuleEnv_C,
66 delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,
67 lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,
68 moduleEnvKeys, moduleEnvElts, moduleEnvToList,
69 unitModuleEnv, isEmptyModuleEnv,
70 foldModuleEnv, extendModuleEnvWith, filterModuleEnv,
71
72 -- * ModuleName mappings
73 ModuleNameEnv,
74
75 -- * Sets of Modules
76 ModuleSet,
77 emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
78 ) where
79
80 import Config
81 import Outputable
82 import Unique
83 import UniqFM
84 import FastString
85 import Binary
86 import Util
87 import {-# SOURCE #-} Packages
88 import GHC.PackageDb (BinaryStringRep(..))
89
90 import Data.Data
91 import Data.Map (Map)
92 import qualified Data.Map as Map
93 import qualified FiniteMap as Map
94 import System.FilePath
95
96 {-
97 ************************************************************************
98 * *
99 \subsection{Module locations}
100 * *
101 ************************************************************************
102 -}
103
104 -- | Where a module lives on the file system: the actual locations
105 -- of the .hs, .hi and .o files, if we have them
106 data ModLocation
107 = ModLocation {
108 ml_hs_file :: Maybe FilePath,
109 -- The source file, if we have one. Package modules
110 -- probably don't have source files.
111
112 ml_hi_file :: FilePath,
113 -- Where the .hi file is, whether or not it exists
114 -- yet. Always of form foo.hi, even if there is an
115 -- hi-boot file (we add the -boot suffix later)
116
117 ml_obj_file :: FilePath
118 -- Where the .o file is, whether or not it exists yet.
119 -- (might not exist either because the module hasn't
120 -- been compiled yet, or because it is part of a
121 -- package with a .a file)
122 } deriving Show
123
124 instance Outputable ModLocation where
125 ppr = text . show
126
127 {-
128 For a module in another package, the hs_file and obj_file
129 components of ModLocation are undefined.
130
131 The locations specified by a ModLocation may or may not
132 correspond to actual files yet: for example, even if the object
133 file doesn't exist, the ModLocation still contains the path to
134 where the object file will reside if/when it is created.
135 -}
136
137 addBootSuffix :: FilePath -> FilePath
138 -- ^ Add the @-boot@ suffix to .hs, .hi and .o files
139 addBootSuffix path = path ++ "-boot"
140
141 addBootSuffix_maybe :: Bool -> FilePath -> FilePath
142 -- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@
143 addBootSuffix_maybe is_boot path
144 | is_boot = addBootSuffix path
145 | otherwise = path
146
147 addBootSuffixLocn :: ModLocation -> ModLocation
148 -- ^ Add the @-boot@ suffix to all file paths associated with the module
149 addBootSuffixLocn locn
150 = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn)
151 , ml_hi_file = addBootSuffix (ml_hi_file locn)
152 , ml_obj_file = addBootSuffix (ml_obj_file locn) }
153
154 {-
155 ************************************************************************
156 * *
157 \subsection{The name of a module}
158 * *
159 ************************************************************************
160 -}
161
162 -- | A ModuleName is essentially a simple string, e.g. @Data.List@.
163 newtype ModuleName = ModuleName FastString
164 deriving Typeable
165
166 instance Uniquable ModuleName where
167 getUnique (ModuleName nm) = getUnique nm
168
169 instance Eq ModuleName where
170 nm1 == nm2 = getUnique nm1 == getUnique nm2
171
172 -- Warning: gives an ordering relation based on the uniques of the
173 -- FastStrings which are the (encoded) module names. This is _not_
174 -- a lexicographical ordering.
175 instance Ord ModuleName where
176 nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
177
178 instance Outputable ModuleName where
179 ppr = pprModuleName
180
181 instance Binary ModuleName where
182 put_ bh (ModuleName fs) = put_ bh fs
183 get bh = do fs <- get bh; return (ModuleName fs)
184
185 instance BinaryStringRep ModuleName where
186 fromStringRep = mkModuleNameFS . mkFastStringByteString
187 toStringRep = fastStringToByteString . moduleNameFS
188
189 instance Data ModuleName where
190 -- don't traverse?
191 toConstr _ = abstractConstr "ModuleName"
192 gunfold _ _ = error "gunfold"
193 dataTypeOf _ = mkNoRepType "ModuleName"
194
195 stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering
196 -- ^ Compares module names lexically, rather than by their 'Unique's
197 stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2
198
199 pprModuleName :: ModuleName -> SDoc
200 pprModuleName (ModuleName nm) =
201 getPprStyle $ \ sty ->
202 if codeStyle sty
203 then ztext (zEncodeFS nm)
204 else ftext nm
205
206 moduleNameFS :: ModuleName -> FastString
207 moduleNameFS (ModuleName mod) = mod
208
209 moduleNameString :: ModuleName -> String
210 moduleNameString (ModuleName mod) = unpackFS mod
211
212 mkModuleName :: String -> ModuleName
213 mkModuleName s = ModuleName (mkFastString s)
214
215 mkModuleNameFS :: FastString -> ModuleName
216 mkModuleNameFS s = ModuleName s
217
218 -- |Returns the string version of the module name, with dots replaced by slashes.
219 --
220 moduleNameSlashes :: ModuleName -> String
221 moduleNameSlashes = dots_to_slashes . moduleNameString
222 where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)
223
224 -- |Returns the string version of the module name, with dots replaced by underscores.
225 --
226 moduleNameColons :: ModuleName -> String
227 moduleNameColons = dots_to_colons . moduleNameString
228 where dots_to_colons = map (\c -> if c == '.' then ':' else c)
229
230 {-
231 ************************************************************************
232 * *
233 \subsection{A fully qualified module}
234 * *
235 ************************************************************************
236 -}
237
238 -- | A Module is a pair of a 'PackageKey' and a 'ModuleName'.
239 data Module = Module {
240 modulePackageKey :: !PackageKey, -- pkg-1.0
241 moduleName :: !ModuleName -- A.B.C
242 }
243 deriving (Eq, Ord, Typeable)
244
245 instance Uniquable Module where
246 getUnique (Module p n) = getUnique (packageKeyFS p `appendFS` moduleNameFS n)
247
248 instance Outputable Module where
249 ppr = pprModule
250
251 instance Binary Module where
252 put_ bh (Module p n) = put_ bh p >> put_ bh n
253 get bh = do p <- get bh; n <- get bh; return (Module p n)
254
255 instance Data Module where
256 -- don't traverse?
257 toConstr _ = abstractConstr "Module"
258 gunfold _ _ = error "gunfold"
259 dataTypeOf _ = mkNoRepType "Module"
260
261 -- | This gives a stable ordering, as opposed to the Ord instance which
262 -- gives an ordering based on the 'Unique's of the components, which may
263 -- not be stable from run to run of the compiler.
264 stableModuleCmp :: Module -> Module -> Ordering
265 stableModuleCmp (Module p1 n1) (Module p2 n2)
266 = (p1 `stablePackageKeyCmp` p2) `thenCmp`
267 (n1 `stableModuleNameCmp` n2)
268
269 mkModule :: PackageKey -> ModuleName -> Module
270 mkModule = Module
271
272 pprModule :: Module -> SDoc
273 pprModule mod@(Module p n) =
274 pprPackagePrefix p mod <> pprModuleName n
275
276 pprPackagePrefix :: PackageKey -> Module -> SDoc
277 pprPackagePrefix p mod = getPprStyle doc
278 where
279 doc sty
280 | codeStyle sty =
281 if p == mainPackageKey
282 then empty -- never qualify the main package in code
283 else ztext (zEncodeFS (packageKeyFS p)) <> char '_'
284 | qualModule sty mod = ppr (modulePackageKey mod) <> char ':'
285 -- the PrintUnqualified tells us which modules have to
286 -- be qualified with package names
287 | otherwise = empty
288
289 class ContainsModule t where
290 extractModule :: t -> Module
291
292 class HasModule m where
293 getModule :: m Module
294
295 {-
296 ************************************************************************
297 * *
298 \subsection{PackageKey}
299 * *
300 ************************************************************************
301 -}
302
303 -- | A string which uniquely identifies a package. For wired-in packages,
304 -- it is just the package name, but for user compiled packages, it is a hash.
305 -- ToDo: when the key is a hash, we can do more clever things than store
306 -- the hex representation and hash-cons those strings.
307 newtype PackageKey = PId FastString deriving( Eq, Typeable )
308 -- here to avoid module loops with PackageConfig
309
310 instance Uniquable PackageKey where
311 getUnique pid = getUnique (packageKeyFS pid)
312
313 -- Note: *not* a stable lexicographic ordering, a faster unique-based
314 -- ordering.
315 instance Ord PackageKey where
316 nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
317
318 instance Data PackageKey where
319 -- don't traverse?
320 toConstr _ = abstractConstr "PackageKey"
321 gunfold _ _ = error "gunfold"
322 dataTypeOf _ = mkNoRepType "PackageKey"
323
324 stablePackageKeyCmp :: PackageKey -> PackageKey -> Ordering
325 -- ^ Compares package ids lexically, rather than by their 'Unique's
326 stablePackageKeyCmp p1 p2 = packageKeyFS p1 `compare` packageKeyFS p2
327
328 instance Outputable PackageKey where
329 ppr pk = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags ->
330 case packageKeyPackageIdString dflags pk of
331 Nothing -> ftext (packageKeyFS pk)
332 Just pkg -> text pkg
333 -- Don't bother qualifying if it's wired in!
334 <> (if qualPackage sty pk && not (pk `elem` wiredInPackageKeys)
335 then char '@' <> ftext (packageKeyFS pk)
336 else empty)
337
338 instance Binary PackageKey where
339 put_ bh pid = put_ bh (packageKeyFS pid)
340 get bh = do { fs <- get bh; return (fsToPackageKey fs) }
341
342 instance BinaryStringRep PackageKey where
343 fromStringRep = fsToPackageKey . mkFastStringByteString
344 toStringRep = fastStringToByteString . packageKeyFS
345
346 fsToPackageKey :: FastString -> PackageKey
347 fsToPackageKey = PId
348
349 packageKeyFS :: PackageKey -> FastString
350 packageKeyFS (PId fs) = fs
351
352 stringToPackageKey :: String -> PackageKey
353 stringToPackageKey = fsToPackageKey . mkFastString
354
355 packageKeyString :: PackageKey -> String
356 packageKeyString = unpackFS . packageKeyFS
357
358
359 -- -----------------------------------------------------------------------------
360 -- $wired_in_packages
361 -- Certain packages are known to the compiler, in that we know about certain
362 -- entities that reside in these packages, and the compiler needs to
363 -- declare static Modules and Names that refer to these packages. Hence
364 -- the wired-in packages can't include version numbers, since we don't want
365 -- to bake the version numbers of these packages into GHC.
366 --
367 -- So here's the plan. Wired-in packages are still versioned as
368 -- normal in the packages database, and you can still have multiple
369 -- versions of them installed. However, for each invocation of GHC,
370 -- only a single instance of each wired-in package will be recognised
371 -- (the desired one is selected via @-package@\/@-hide-package@), and GHC
372 -- will use the unversioned 'PackageKey' below when referring to it,
373 -- including in .hi files and object file symbols. Unselected
374 -- versions of wired-in packages will be ignored, as will any other
375 -- package that depends directly or indirectly on it (much as if you
376 -- had used @-ignore-package@).
377
378 -- Make sure you change 'Packages.findWiredInPackages' if you add an entry here
379
380 integerPackageKey, primPackageKey,
381 basePackageKey, rtsPackageKey,
382 thPackageKey, dphSeqPackageKey, dphParPackageKey,
383 mainPackageKey, thisGhcPackageKey, interactivePackageKey :: PackageKey
384 primPackageKey = fsToPackageKey (fsLit "ghc-prim")
385 integerPackageKey = fsToPackageKey (fsLit n)
386 where
387 n = case cIntegerLibraryType of
388 IntegerGMP -> "integer-gmp"
389 IntegerSimple -> "integer-simple"
390 basePackageKey = fsToPackageKey (fsLit "base")
391 rtsPackageKey = fsToPackageKey (fsLit "rts")
392 thPackageKey = fsToPackageKey (fsLit "template-haskell")
393 dphSeqPackageKey = fsToPackageKey (fsLit "dph-seq")
394 dphParPackageKey = fsToPackageKey (fsLit "dph-par")
395 thisGhcPackageKey = fsToPackageKey (fsLit "ghc")
396 interactivePackageKey = fsToPackageKey (fsLit "interactive")
397
398 -- | This is the package Id for the current program. It is the default
399 -- package Id if you don't specify a package name. We don't add this prefix
400 -- to symbol names, since there can be only one main package per program.
401 mainPackageKey = fsToPackageKey (fsLit "main")
402
403 -- | This is a fake package id used to provide identities to any un-implemented
404 -- signatures. The set of hole identities is global over an entire compilation.
405 holePackageKey :: PackageKey
406 holePackageKey = fsToPackageKey (fsLit "hole")
407
408 isInteractiveModule :: Module -> Bool
409 isInteractiveModule mod = modulePackageKey mod == interactivePackageKey
410
411 isHoleModule :: Module -> Bool
412 isHoleModule mod = modulePackageKey mod == holePackageKey
413
414 wiredInPackageKeys :: [PackageKey]
415 wiredInPackageKeys = [ primPackageKey,
416 integerPackageKey,
417 basePackageKey,
418 rtsPackageKey,
419 thPackageKey,
420 thisGhcPackageKey,
421 dphSeqPackageKey,
422 dphParPackageKey ]
423
424 {-
425 ************************************************************************
426 * *
427 \subsection{@ModuleEnv@s}
428 * *
429 ************************************************************************
430 -}
431
432 -- | A map keyed off of 'Module's
433 newtype ModuleEnv elt = ModuleEnv (Map Module elt)
434
435 filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
436 filterModuleEnv f (ModuleEnv e) = ModuleEnv (Map.filterWithKey f e)
437
438 elemModuleEnv :: Module -> ModuleEnv a -> Bool
439 elemModuleEnv m (ModuleEnv e) = Map.member m e
440
441 extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a
442 extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert m x e)
443
444 extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
445 extendModuleEnvWith f (ModuleEnv e) m x = ModuleEnv (Map.insertWith f m x e)
446
447 extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a
448 extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (Map.insertList xs e)
449
450 extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)]
451 -> ModuleEnv a
452 extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (Map.insertListWith f xs e)
453
454 plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
455 plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.unionWith f e1 e2)
456
457 delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a
458 delModuleEnvList (ModuleEnv e) ms = ModuleEnv (Map.deleteList ms e)
459
460 delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a
461 delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete m e)
462
463 plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a
464 plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2)
465
466 lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a
467 lookupModuleEnv (ModuleEnv e) m = Map.lookup m e
468
469 lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a
470 lookupWithDefaultModuleEnv (ModuleEnv e) x m = Map.findWithDefault x m e
471
472 mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b
473 mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e)
474
475 mkModuleEnv :: [(Module, a)] -> ModuleEnv a
476 mkModuleEnv xs = ModuleEnv (Map.fromList xs)
477
478 emptyModuleEnv :: ModuleEnv a
479 emptyModuleEnv = ModuleEnv Map.empty
480
481 moduleEnvKeys :: ModuleEnv a -> [Module]
482 moduleEnvKeys (ModuleEnv e) = Map.keys e
483
484 moduleEnvElts :: ModuleEnv a -> [a]
485 moduleEnvElts (ModuleEnv e) = Map.elems e
486
487 moduleEnvToList :: ModuleEnv a -> [(Module, a)]
488 moduleEnvToList (ModuleEnv e) = Map.toList e
489
490 unitModuleEnv :: Module -> a -> ModuleEnv a
491 unitModuleEnv m x = ModuleEnv (Map.singleton m x)
492
493 isEmptyModuleEnv :: ModuleEnv a -> Bool
494 isEmptyModuleEnv (ModuleEnv e) = Map.null e
495
496 foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b
497 foldModuleEnv f x (ModuleEnv e) = Map.foldRightWithKey (\_ v -> f v) x e
498
499 -- | A set of 'Module's
500 type ModuleSet = Map Module ()
501
502 mkModuleSet :: [Module] -> ModuleSet
503 extendModuleSet :: ModuleSet -> Module -> ModuleSet
504 emptyModuleSet :: ModuleSet
505 moduleSetElts :: ModuleSet -> [Module]
506 elemModuleSet :: Module -> ModuleSet -> Bool
507
508 emptyModuleSet = Map.empty
509 mkModuleSet ms = Map.fromList [(m,()) | m <- ms ]
510 extendModuleSet s m = Map.insert m () s
511 moduleSetElts = Map.keys
512 elemModuleSet = Map.member
513
514 {-
515 A ModuleName has a Unique, so we can build mappings of these using
516 UniqFM.
517 -}
518
519 -- | A map keyed off of 'ModuleName's (actually, their 'Unique's)
520 type ModuleNameEnv elt = UniqFM elt