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