git.iko.soy/stackage
on 48c9d56 help sign in
stackage/Stackage/LoadDatabase.hs
96 lines 4.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.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 -- ^ 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
58 | not $ withinRange v vrange -> return pdb
59 _ ->
60 case Tar.entryContent e of
61 Tar.NormalFile bs _ -> return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
62 { piVersion = v
63 , piDeps = parseDeps bs
64 }
65 _ -> return pdb
67 parseDeps lbs =
68 case parsePackageDescription $ L8.unpack lbs of
69 ParseOk _ gpd -> mconcat
70 [ maybe mempty (go gpd) $ condLibrary gpd
71 , mconcat $ map (go gpd . snd) $ condExecutables gpd
72 , mconcat $ map (go gpd . snd) $ condTestSuites gpd
73 , mconcat $ map (go gpd . snd) $ condBenchmarks gpd
74 ]
75 _ -> mempty
76 where
77 go gpd tree
78 = Set.unions
79 $ Set.fromList (map (\(Dependency p _) -> p) $ condTreeConstraints tree)
80 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
82 checkCond gpd (cond, tree, melse)
83 | checkCond' cond = Just tree
84 | otherwise = melse
85 where
86 checkCond' (Var (OS os)) = os == buildOS
87 checkCond' (Var (Arch arch)) = arch == buildArch
88 checkCond' (Var (Flag flag)) = flag `elem` flags
89 checkCond' (Var (Impl compiler range)) =
90 compiler == GHC && withinRange targetCompilerVersion range
91 checkCond' (Lit b) = b
92 checkCond' (CNot c) = not $ checkCond' c
93 checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2
94 checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2
96 flags = map flagName $ filter flagDefault $ genPackageFlags gpd