git.iko.soy/stackage
on 4624ae2 help sign in
stackage/Stackage/LoadDatabase.hs
74 lines 3.4 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 condTreeConstraints)
16import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
17 parsePackageDescription)
18import Distribution.Version (withinRange)
19import Stackage.Types
20import Stackage.Util
22-- | Load the raw package database.
23--
24-- We want to put in some restrictions:
25--
26-- * Drop all core packages. We never want to install a new version of
27-- those, nor include them in the package list.
28--
29-- * For packages with a specific version bound, find the maximum matching
30-- version.
31--
32-- * For other packages, select the maximum version number.
33loadPackageDB :: Set PackageName -- ^ core packages
34 -> Map PackageName VersionRange -- ^ additional deps
35 -> IO PackageDB
36loadPackageDB core deps = do
37 tarName <- getTarballName
38 lbs <- L.readFile tarName
39 addEntries mempty $ Tar.read lbs
40 where
41 addEntries :: PackageDB -> Tar.Entries Tar.FormatError -> IO PackageDB
42 addEntries _ (Tar.Fail e) = throwIO e
43 addEntries db Tar.Done = return db
44 addEntries db (Tar.Next e es) = addEntry db e >>= flip addEntries es
46 addEntry :: PackageDB -> Tar.Entry -> IO PackageDB
47 addEntry pdb e =
48 case getPackageVersion e of
49 Nothing -> return pdb
50 Just (p, v)
51 | p `member` core -> return pdb
52 | otherwise ->
53 case Map.lookup p deps of
54 Just vrange
55 | not $ withinRange v vrange -> return pdb
56 _ ->
57 case Tar.entryContent e of
58 Tar.NormalFile bs _ -> return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
59 { piVersion = v
60 , piDeps = parseDeps bs
61 }
62 _ -> return pdb
64 parseDeps lbs =
65 case parsePackageDescription $ L8.unpack lbs of
66 ParseOk _ gpd -> mconcat
67 [ maybe mempty go $ condLibrary gpd
68 , mconcat $ map (go . snd) $ condExecutables gpd
69 , mconcat $ map (go . snd) $ condTestSuites gpd
70 -- , mconcat $ map (go . snd) $ condBenchmarks gpd
71 ]
72 _ -> mempty
73 where
74 go = Set.fromList . map (\(Dependency p _) -> p) . condTreeConstraints