/
Add.hs
144 lines (130 loc) · 5.49 KB
/
Add.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
{-
- Copyright 2011-2014 Per Magnus Therning
-
- Licensed under the Apache License, Version 2.0 (the "License");
- you may not use this file except in compliance with the License.
- You may obtain a copy of the License at
-
- http://www.apache.org/licenses/LICENSE-2.0
-
- Unless required by applicable law or agreed to in writing, software
- distributed under the License is distributed on an "AS IS" BASIS,
- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
- See the License for the specific language governing permissions and
- limitations under the License.
-}
module Add where
-- {{{1 imports
-- {{{2 local
import PkgDB
import qualified Util.Cabal as Cbl
import Util.Misc
import Util.Dist
-- {{{2 system
import Control.Monad.Reader
import Data.List
import Data.Maybe
import Distribution.PackageDescription
import Distribution.Version
import qualified Distribution.Package as P
import Control.Arrow
import Data.Monoid
import Data.Either
import System.Unix.Directory
-- {{{1 types
data PkgType
= GhcType String Version
| DistroType String Version Int
| RepoType GenericPackageDescription
deriving (Eq, Show)
-- {{{1 add
add :: Command ()
add = do
dbFn <- asks dbFile
db <- liftIO $ readDb dbFn
dr <- asks dryRun
ghcVersion <- asks $ ghcVer . optsCmd
filePkgs <- asks $ cmdAddFileCbls . optsCmd
idxPkgs <- asks $ cmdAddCbls . optsCmd
--
ghcPkgs <- asks $ map (uncurry GhcType) . cmdAddGhcPkgs . optsCmd
distroPkgs <- asks $ map (\ (n, v, r) -> DistroType n v r) . cmdAddDistroPkgs . optsCmd
genFilePkgs <- mapM (runCabalParseWithTempDir . fmap snd . Cbl.readFromFile . fst) filePkgs
genIdxPkgs <- mapM ((runCabalParseWithTempDir . fmap snd . Cbl.readFromIdx) . (\ (a, b, _) -> (a, b))) idxPkgs
genPkgs <- liftM (map RepoType) $ exitOnAnyLefts (genFilePkgs ++ genIdxPkgs)
--
let pkgs = ghcPkgs ++ distroPkgs ++ genPkgs
pkgNames = map getName pkgs
tmpDb = foldl delPkg db pkgNames
oldFlags = map (maybe ([], []) (pkgName &&& pkgFlags) . lookupPkg db . getName) pkgs
fileFlags = map (\ (pkg, (_, fa)) -> (pkgNameStr pkg, fa))
(zip (rights genFilePkgs) filePkgs)
idxFlags = map (\ (a, _, b) -> (a, b)) idxPkgs
flags = fileFlags `combineFlags` idxFlags `combineFlags` oldFlags
case addPkgs ghcVersion tmpDb flags pkgs of
Left (unsatisfiables, breaksOthers) -> liftIO (mapM_ printUnSat unsatisfiables >> mapM_ printBrksOth breaksOthers)
Right newDb -> liftIO $ unless dr $ saveDb newDb dbFn
runCabalParseWithTempDir :: Cbl.CabalParse a -> Command (Either String a)
runCabalParseWithTempDir f = do
aD <- asks appDir
pD <- asks $ patchDir . optsCmd
liftIO $ withTemporaryDirectory "/tmp/cblrepo." $ \ destDir -> do
let cpe = Cbl.CabalParseEnv aD pD destDir
Cbl.runCabalParse cpe f
getName (GhcType n _) = n
getName (DistroType n _ _) = n
getName (RepoType gpd) = pkgNameStr $ packageDescription gpd
-- {{{1 addPkgs
addPkgs :: Version -> CblDB -> [(String, FlagAssignment)] -> [PkgType] -> Either ([(String, [P.Dependency])], [((String, Version), [(String, Maybe P.Dependency)])]) CblDB
addPkgs ghcVer db flags pkgs = let
(succs, fails) = partition (canBeAdded ghcVer db flags) pkgs
newDb = foldl addPkg2 db (map (pkgTypeToCblPkg ghcVer db flags) succs)
unsatisfieds = mapMaybe (finalizeToUnsatisfiableDeps ghcVer db flags) fails
breaksOthers = mapMaybe (findBreaking db) fails
in case (succs, fails) of
(_, []) -> Right newDb
([], _) -> Left (unsatisfieds, breaksOthers)
(_, _) -> addPkgs ghcVer newDb flags fails
canBeAdded :: Version -> CblDB -> [(String, FlagAssignment)] -> PkgType -> Bool
canBeAdded _ db _ (GhcType n v) = null $ checkDependants db n v
canBeAdded _ db _ (DistroType n v _) = null $ checkDependants db n v
canBeAdded ghcVer db flags pkg@(RepoType gpd) = finable && depsOK
where
fa = fromMaybe [] $ lookup (getName pkg) flags
finable = either (const False) (const True) (finalizePkg ghcVer db fa gpd)
n = pkgNameStr (packageDescription gpd)
v = P.pkgVersion $ package $ packageDescription gpd
depsOK = null $ checkDependants db n v
pkgTypeToCblPkg _ _ _ (GhcType n v) = createGhcPkg n v
pkgTypeToCblPkg _ _ _ (DistroType n v r) = createDistroPkg n v r
pkgTypeToCblPkg ghcVer db flags pkg@(RepoType gpd) =
let fa = fromMaybe [] $ lookup (getName pkg) flags
in fromJust $ case finalizePkg ghcVer db fa gpd of
Right (pd, fa) -> Just $ createCblPkg pd fa
Left _ -> Nothing
finalizeToUnsatisfiableDeps ghcVer db flags pkg@(RepoType gpd) =
let fa = fromMaybe [] $ lookup (getName pkg) flags
in case finalizePkg ghcVer db fa gpd of
Left ds -> Just (pkgNameStr (packageDescription gpd), ds)
_ -> Nothing
finalizeToUnsatisfiableDeps _ _ _ _ = Nothing
findBreaking db (GhcType n v) = let
d = checkDependants db n v
in if null d
then Nothing
else Just ((n, v), d)
findBreaking db (DistroType n v _) = let
d = checkDependants db n v
in if null d
then Nothing
else Just ((n, v), d)
findBreaking db (RepoType gpd) = let
n = pkgNameStr (packageDescription gpd)
v = P.pkgVersion $ package $ packageDescription gpd
d = checkDependants db n v
in if null d
then Nothing
else Just ((n, v), d)
combineFlags a b = zip keys $ mapMaybe (uncurry mappend . (\ k -> (lookup k a, lookup k b))) keys
where
keys = nub $ map fst (a ++ b)