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