git.iko.soy/stackage
on e005ca2 help sign in
stackage/Stackage/LoadDatabase.hs
124 lines 6.4 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 benchmarkBuildInfo,
16 buildInfo, buildTools,
17 condBenchmarks,
18 condExecutables,
19 condLibrary,
20 condTestSuites,
21 condTreeComponents,
22 condTreeConstraints,
23 condTreeData,
24 flagDefault, flagName,
25 genPackageFlags,
26 libBuildInfo,
27 testBuildInfo,
28 FlagName (FlagName))
29import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
30 parsePackageDescription)
31import Distribution.System (buildArch, buildOS)
32import Distribution.Version (withinRange, unionVersionRanges)
33import Stackage.Config
34import Stackage.Types
35import Stackage.Util
37-- | Load the raw package database.
38--
39-- We want to put in some restrictions:
40--
41-- * Drop all core packages. We never want to install a new version of
42-- those, nor include them in the package list.
43--
44-- * For packages with a specific version bound, find the maximum matching
45-- version.
46--
47-- * For other packages, select the maximum version number.
48loadPackageDB :: BuildSettings
49 -> Set PackageName -- ^ core packages
50 -> Map PackageName (VersionRange, Maintainer) -- ^ additional deps
51 -> IO PackageDB
52loadPackageDB settings 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', mgpd) = parseDeps bs
75 return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
76 { piVersion = v
77 , piDeps = deps'
78 , piHasTests = hasTests
79 , piBuildTools = buildTools'
80 , piGPD = mgpd
81 }
82 _ -> return pdb
84 parseDeps lbs =
85 case parsePackageDescription $ L8.unpack lbs of
86 ParseOk _ gpd -> (mconcat
87 [ maybe mempty (go gpd) $ condLibrary gpd
88 , mconcat $ map (go gpd . snd) $ condExecutables gpd
89 , mconcat $ map (go gpd . snd) $ condTestSuites gpd
90 , mconcat $ map (go gpd . snd) $ condBenchmarks gpd
91 ], not $ null $ condTestSuites gpd
92 , Set.fromList $ map depName $ allBuildInfo gpd, Just gpd)
93 _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing)
94 where
95 allBuildInfo gpd = concat
96 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd
97 , concat $ map (goBI buildInfo . snd) $ condExecutables gpd
98 , concat $ map (goBI testBuildInfo . snd) $ condTestSuites gpd
99 , concat $ map (goBI benchmarkBuildInfo . snd) $ condBenchmarks gpd
100 ]
101 where
102 goBI f x = buildTools $ f $ condTreeData x
103 depName (Dependency p _) = p
104 go gpd tree
105 = Map.unionsWith unionVersionRanges
106 $ Map.fromList (map (\(Dependency p vr) -> (p, vr)) $ condTreeConstraints tree)
107 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
109 checkCond gpd (cond, tree, melse)
110 | checkCond' cond = Just tree
111 | otherwise = melse
112 where
113 checkCond' (Var (OS os)) = os == buildOS
114 checkCond' (Var (Arch arch)) = arch == buildArch
115 checkCond' (Var (Flag flag)) = flag `elem` flags'
116 checkCond' (Var (Impl compiler range)) =
117 compiler == GHC && withinRange targetCompilerVersion range
118 checkCond' (Lit b) = b
119 checkCond' (CNot c) = not $ checkCond' c
120 checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2
121 checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2
123 flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++
124 (map FlagName $ Set.toList $ Stackage.Types.flags settings)