git.iko.soy/stackage
on a609f1f help sign in
stackage/Stackage/LoadDatabase.hs
122 lines 6.2 kB history raw
1module Stackage.LoadDatabase where
3import qualified Codec.Archive.Tar as Tar
4import qualified Data.ByteString.Lazy as L
5import qualified Data.ByteString.Lazy.Char8 as L8
6import qualified Data.Map as Map
7import Data.Maybe (mapMaybe)
8import Data.Monoid (Monoid (..))
9import Data.Set (member)
10import qualified Data.Set as Set
11import Distribution.Compiler (CompilerFlavor (GHC))
12import Distribution.Package (Dependency (Dependency))
13import Distribution.PackageDescription (Condition (..),
14 ConfVar (..),
15 allBuildInfo,
16 benchmarkBuildInfo,
17 buildInfo, buildTools,
18 condBenchmarks,
19 condExecutables,
20 condLibrary,
21 condTestSuites,
22 condTreeComponents,
23 condTreeConstraints,
24 condTreeData,
25 flagDefault, flagName,
26 genPackageFlags,
27 libBuildInfo,
28 packageDescription,
29 testBuildInfo)
30import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
31 parsePackageDescription)
32import Distribution.System (buildArch, buildOS)
33import Distribution.Version (withinRange, unionVersionRanges)
34import Stackage.Config
35import Stackage.Types
36import Stackage.Util
38-- | Load the raw package database.
39--
40-- We want to put in some restrictions:
41--
42-- * Drop all core packages. We never want to install a new version of
43-- those, nor include them in the package list.
44--
45-- * For packages with a specific version bound, find the maximum matching
46-- version.
47--
48-- * For other packages, select the maximum version number.
49loadPackageDB :: Set PackageName -- ^ core packages
50 -> Map PackageName (VersionRange, Maintainer) -- ^ additional deps
51 -> IO PackageDB
52loadPackageDB core deps = do
53 tarName <- getTarballName
54 lbs <- L.readFile tarName
55 addEntries mempty $ Tar.read lbs
56 where
57 addEntries _ (Tar.Fail e) = error $ show e
58 addEntries db Tar.Done = return db
59 addEntries db (Tar.Next e es) = addEntry db e >>= flip addEntries es
61 addEntry :: PackageDB -> Tar.Entry -> IO PackageDB
62 addEntry pdb e =
63 case getPackageVersion e of
64 Nothing -> return pdb
65 Just (p, v)
66 | p `member` core -> return pdb
67 | otherwise ->
68 case Map.lookup p deps of
69 Just (vrange, _maintainer)
70 | not $ withinRange v vrange -> return pdb
71 _ ->
72 case Tar.entryContent e of
73 Tar.NormalFile bs _ -> do
74 let (deps', hasTests, buildTools) = parseDeps bs
75 return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
76 { piVersion = v
77 , piDeps = deps'
78 , piHasTests = hasTests
79 , piBuildTools = buildTools
80 }
81 _ -> return pdb
83 parseDeps lbs =
84 case parsePackageDescription $ L8.unpack lbs of
85 ParseOk _ gpd -> (mconcat
86 [ maybe mempty (go gpd) $ condLibrary gpd
87 , mconcat $ map (go gpd . snd) $ condExecutables gpd
88 , mconcat $ map (go gpd . snd) $ condTestSuites gpd
89 , mconcat $ map (go gpd . snd) $ condBenchmarks gpd
90 ], not $ null $ condTestSuites gpd
91 , Set.fromList $ map depName $ allBuildInfo gpd)
92 _ -> (mempty, defaultHasTestSuites, Set.empty)
93 where
94 allBuildInfo gpd = concat
95 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd
96 , concat $ map (goBI buildInfo . snd) $ condExecutables gpd
97 , concat $ map (goBI testBuildInfo . snd) $ condTestSuites gpd
98 , concat $ map (goBI benchmarkBuildInfo . snd) $ condBenchmarks gpd
99 ]
100 where
101 goBI f x = buildTools $ f $ condTreeData x
102 depName (Dependency p _) = p
103 go gpd tree
104 = Map.unionsWith unionVersionRanges
105 $ Map.fromList (map (\(Dependency p vr) -> (p, vr)) $ condTreeConstraints tree)
106 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
108 checkCond gpd (cond, tree, melse)
109 | checkCond' cond = Just tree
110 | otherwise = melse
111 where
112 checkCond' (Var (OS os)) = os == buildOS
113 checkCond' (Var (Arch arch)) = arch == buildArch
114 checkCond' (Var (Flag flag)) = flag `elem` flags
115 checkCond' (Var (Impl compiler range)) =
116 compiler == GHC && withinRange targetCompilerVersion range
117 checkCond' (Lit b) = b
118 checkCond' (CNot c) = not $ checkCond' c
119 checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2
120 checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2
122 flags = map flagName $ filter flagDefault $ genPackageFlags gpd