git.iko.soy/stackage
on a4dd7d5 help sign in
stackage/Stackage/LoadDatabase.hs
97 lines 4.5 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 _ (Tar.Fail e) = error $ show e
47 addEntries db Tar.Done = return db
48 addEntries db (Tar.Next e es) = addEntry db e >>= flip addEntries es
50 addEntry :: PackageDB -> Tar.Entry -> IO PackageDB
51 addEntry pdb e =
52 case getPackageVersion e of
53 Nothing -> return pdb
54 Just (p, v)
55 | p `member` core -> return pdb
56 | otherwise ->
57 case Map.lookup p deps of
58 Just vrange
59 | not $ withinRange v vrange -> return pdb
60 _ ->
61 case Tar.entryContent e of
62 Tar.NormalFile bs _ -> return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
63 { piVersion = v
64 , piDeps = parseDeps bs
65 }
66 _ -> return pdb
68 parseDeps lbs =
69 case parsePackageDescription $ L8.unpack lbs of
70 ParseOk _ gpd -> mconcat
71 [ maybe mempty (go gpd) $ condLibrary gpd
72 , mconcat $ map (go gpd . snd) $ condExecutables gpd
73 , mconcat $ map (go gpd . snd) $ condTestSuites gpd
74 , mconcat $ map (go gpd . snd) $ condBenchmarks gpd
75 ]
76 _ -> mempty
77 where
78 go gpd tree
79 = Set.unions
80 $ Set.fromList (map (\(Dependency p _) -> p) $ condTreeConstraints tree)
81 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
83 checkCond gpd (cond, tree, melse)
84 | checkCond' cond = Just tree
85 | otherwise = melse
86 where
87 checkCond' (Var (OS os)) = os == buildOS
88 checkCond' (Var (Arch arch)) = arch == buildArch
89 checkCond' (Var (Flag flag)) = flag `elem` flags
90 checkCond' (Var (Impl compiler range)) =
91 compiler == GHC && withinRange targetCompilerVersion range
92 checkCond' (Lit b) = b
93 checkCond' (CNot c) = not $ checkCond' c
94 checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2
95 checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2
97 flags = map flagName $ filter flagDefault $ genPackageFlags gpd