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