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