| ... |
... |
@@ -23,6 +23,7 @@ |
|
23
|
23
|
|
|
24
|
24
|
module Main (main) where
|
|
25
|
25
|
|
|
|
26
|
+import qualified GHC.Arr as Array
|
|
26
|
27
|
import qualified GHC.Unit.Database as GhcPkg
|
|
27
|
28
|
import GHC.Unit.Database hiding (mkMungePathUrl)
|
|
28
|
29
|
import GHC.HandleEncoding
|
| ... |
... |
@@ -32,7 +33,6 @@ import GHC.Platform.Host (hostPlatformArchOS) |
|
32
|
33
|
import GHC.UniqueSubdir (uniqueSubdir)
|
|
33
|
34
|
import qualified GHC.Data.ShortText as ST
|
|
34
|
35
|
import GHC.Version ( cProjectVersion )
|
|
35
|
|
-import qualified Distribution.Simple.PackageIndex as PackageIndex
|
|
36
|
36
|
import qualified Data.Graph as Graph
|
|
37
|
37
|
import qualified Distribution.ModuleName as ModuleName
|
|
38
|
38
|
import Distribution.ModuleName (ModuleName)
|
| ... |
... |
@@ -47,7 +47,7 @@ import Distribution.Types.UnqualComponentName |
|
47
|
47
|
import Distribution.Types.LibraryName
|
|
48
|
48
|
import Distribution.Types.MungedPackageName
|
|
49
|
49
|
import Distribution.Types.MungedPackageId
|
|
50
|
|
-import Distribution.Simple.Utils (ignoreBOM, toUTF8BS, toUTF8LBS, fromUTF8LBS)
|
|
|
50
|
+import Distribution.Utils.Generic (ignoreBOM, toUTF8BS, toUTF8LBS, fromUTF8LBS)
|
|
51
|
51
|
import qualified Data.Version as Version
|
|
52
|
52
|
import System.OsPath as OsPath
|
|
53
|
53
|
import qualified System.FilePath as FilePath
|
| ... |
... |
@@ -71,6 +71,7 @@ import Data.Maybe |
|
71
|
71
|
import Data.Bifunctor
|
|
72
|
72
|
|
|
73
|
73
|
import Data.Char ( toLower )
|
|
|
74
|
+import Data.Ord ( comparing )
|
|
74
|
75
|
import Control.Monad
|
|
75
|
76
|
import System.Exit ( exitWith, ExitCode(..) )
|
|
76
|
77
|
import System.Environment ( getArgs, getProgName, getEnv )
|
| ... |
... |
@@ -1664,7 +1665,7 @@ showPackageDot verbosity myflags = do |
|
1664
|
1665
|
False{-use user-} True{-use cache-} False{-expand vars-} myflags
|
|
1665
|
1666
|
|
|
1666
|
1667
|
let all_pkgs = allPackagesInStack flag_db_stack
|
|
1667
|
|
- ipix = PackageIndex.fromList all_pkgs
|
|
|
1668
|
+ ipix = Map.fromList [(installedUnitId pkg, pkg) | pkg <- all_pkgs]
|
|
1668
|
1669
|
|
|
1669
|
1670
|
putStrLn "digraph {"
|
|
1670
|
1671
|
let quote s = '"':s ++ "\""
|
| ... |
... |
@@ -1672,7 +1673,7 @@ showPackageDot verbosity myflags = do |
|
1672
|
1673
|
| p <- all_pkgs,
|
|
1673
|
1674
|
let from = display (mungedId p),
|
|
1674
|
1675
|
key <- depends p,
|
|
1675
|
|
- Just dep <- [PackageIndex.lookupUnitId ipix key],
|
|
|
1676
|
+ Just dep <- [Map.lookup key ipix],
|
|
1676
|
1677
|
let to = display (mungedId dep)
|
|
1677
|
1678
|
]
|
|
1678
|
1679
|
putStrLn "}"
|
| ... |
... |
@@ -2155,7 +2156,7 @@ checkModule field_name db_stack pkg |
|
2155
|
2156
|
let definingPkgId = unDefUnitId def_uid
|
|
2156
|
2157
|
mpkg = if definingPkgId == installedUnitId pkg
|
|
2157
|
2158
|
then Just pkg
|
|
2158
|
|
- else PackageIndex.lookupUnitId ipix definingPkgId
|
|
|
2159
|
+ else Map.lookup definingPkgId ipix
|
|
2159
|
2160
|
in case mpkg of
|
|
2160
|
2161
|
Nothing
|
|
2161
|
2162
|
-> verror ForceAll (field_name ++ " refers to a non-existent " ++
|
| ... |
... |
@@ -2185,19 +2186,46 @@ checkModule field_name db_stack pkg |
|
2185
|
2186
|
_ -> return ()
|
|
2186
|
2187
|
where
|
|
2187
|
2188
|
all_pkgs = allPackagesInStack db_stack
|
|
2188
|
|
- ipix = PackageIndex.fromList all_pkgs
|
|
|
2189
|
+ ipix = Map.fromList [(installedUnitId pkg, pkg) | pkg <- all_pkgs]
|
|
2189
|
2190
|
|
|
2190
|
2191
|
isIndirectDependency pkgid = fromMaybe False $ do
|
|
2191
|
2192
|
thispkg <- graphVertex (installedUnitId pkg)
|
|
2192
|
2193
|
otherpkg <- graphVertex pkgid
|
|
2193
|
2194
|
return (Graph.path depgraph thispkg otherpkg)
|
|
2194
|
|
- (depgraph, _, graphVertex) =
|
|
2195
|
|
- PackageIndex.dependencyGraph (PackageIndex.insert pkg ipix)
|
|
|
2195
|
+ (depgraph, graphVertex) =
|
|
|
2196
|
+ dependencyGraph (Map.insert (installedUnitId pkg) pkg ipix)
|
|
2196
|
2197
|
|
|
2197
|
2198
|
checkModule _ _ _ (OpenModule (IndefFullUnitId _ _) _) =
|
|
2198
|
2199
|
-- TODO: add some checks here
|
|
2199
|
2200
|
return ()
|
|
2200
|
2201
|
|
|
|
2202
|
+-- This function was copy pasted from:
|
|
|
2203
|
+-- https://hackage-content.haskell.org/package/Cabal-3.16.1.0/docs/Distribution-Simple-PackageIndex.html#v:dependencyGraph
|
|
|
2204
|
+-- Then we removed the unused lookup table.
|
|
|
2205
|
+dependencyGraph
|
|
|
2206
|
+ :: Map.Map UnitId InstalledPackageInfo
|
|
|
2207
|
+ -> ( Graph.Graph
|
|
|
2208
|
+ , UnitId -> Maybe Graph.Vertex
|
|
|
2209
|
+ )
|
|
|
2210
|
+dependencyGraph index = (graph, id_to_vertex)
|
|
|
2211
|
+ where
|
|
|
2212
|
+ graph =
|
|
|
2213
|
+ Array.listArray
|
|
|
2214
|
+ bounds
|
|
|
2215
|
+ [ [v | Just v <- map id_to_vertex (installedDepends pkg)]
|
|
|
2216
|
+ | pkg <- pkgs
|
|
|
2217
|
+ ]
|
|
|
2218
|
+
|
|
|
2219
|
+ pkgs = sortBy (comparing packageId) (Map.elems index)
|
|
|
2220
|
+ vertices = zip (map installedUnitId pkgs) [0 ..]
|
|
|
2221
|
+ vertex_map = Map.fromList vertices
|
|
|
2222
|
+ id_to_vertex pid = Map.lookup pid vertex_map
|
|
|
2223
|
+
|
|
|
2224
|
+ vertex_to_pkg vertex = pkgTable Array.! vertex
|
|
|
2225
|
+
|
|
|
2226
|
+ pkgTable = Array.listArray bounds pkgs
|
|
|
2227
|
+ topBound = length pkgs - 1
|
|
|
2228
|
+ bounds = (0, topBound)
|
|
2201
|
2229
|
|
|
2202
|
2230
|
-- ---------------------------------------------------------------------------
|
|
2203
|
2231
|
-- expanding environment variables in the package configuration
|