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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.World
-- Copyright : (c) Peter Robinson 2009
-- License : BSD-like
--
-- Maintainer : thaldyron@gmail.com
-- Stability : provisional
-- Portability : portable
--
-- Interface to the world-file that contains a list of explicitly
-- requested packages. Meant to be imported qualified.
--
-- A world file entry stores the package-name, package-version, and
-- user flags.
-- For example, the entry generated by
-- # cabal install stm-io-hooks --flags="-debug"
-- looks like this:
-- # stm-io-hooks -any --flags="-debug"
-- To rebuild/upgrade the packages in world (e.g. when updating the compiler)
-- use
-- # cabal install world
--
-----------------------------------------------------------------------------
module Distribution.Client.World (
WorldPkgInfo(..),
insert,
delete,
getContents,
) where
import Distribution.Package
( Dependency(..) )
import Distribution.PackageDescription
( FlagAssignment, FlagName(FlagName) )
import Distribution.Verbosity
( Verbosity )
import Distribution.Simple.Utils
( die, info, chattyTry, writeFileAtomic )
import Distribution.Text
( Text(..), display, simpleParse )
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.Exception ( catchIO )
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ( (<>), (<+>) )
import Data.Char as Char
import Data.List
( unionBy, deleteFirstsBy, nubBy )
import Data.Maybe
( isJust, fromJust )
import System.IO.Error
( isDoesNotExistError )
import qualified Data.ByteString.Lazy.Char8 as B
import Prelude hiding (getContents)
data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment
deriving (Show,Eq)
-- | Adds packages to the world file; creates the file if it doesn't
-- exist yet. Version constraints and flag assignments for a package are
-- updated if already present. IO errors are non-fatal.
insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()
insert = modifyWorld $ unionBy equalUDep
-- | Removes packages from the world file.
-- Note: Currently unused as there is no mechanism in Cabal (yet) to
-- handle uninstalls. IO errors are non-fatal.
delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()
delete = modifyWorld $ flip (deleteFirstsBy equalUDep)
-- | WorldPkgInfo values are considered equal if they refer to
-- the same package, i.e., we don't care about differing versions or flags.
equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool
equalUDep (WorldPkgInfo (Dependency pkg1 _) _)
(WorldPkgInfo (Dependency pkg2 _) _) = pkg1 == pkg2
-- | Modifies the world file by applying an update-function ('unionBy'
-- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of
-- packages. IO errors are considered non-fatal.
modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo]
-> [WorldPkgInfo])
-- ^ Function that defines how
-- the list of user packages are merged with
-- existing world packages.
-> Verbosity
-> FilePath -- ^ Location of the world file
-> [WorldPkgInfo] -- ^ list of user supplied packages
-> IO ()
modifyWorld _ _ _ [] = return ()
modifyWorld f verbosity world pkgs =
chattyTry "Error while updating world-file. " $ do
pkgsOldWorld <- getContents world
-- Filter out packages that are not in the world file:
let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld
-- 'Dependency' is not an Ord instance, so we need to check for
-- equivalence the awkward way:
if not (all (`elem` pkgsOldWorld) pkgsNewWorld &&
all (`elem` pkgsNewWorld) pkgsOldWorld)
then do
info verbosity "Updating world file..."
writeFileAtomic world . B.pack $ unlines
[ (display pkg) | pkg <- pkgsNewWorld]
else
info verbosity "World file is already up to date."
-- | Returns the content of the world file as a list
getContents :: FilePath -> IO [WorldPkgInfo]
getContents world = do
content <- safelyReadFile world
let result = map simpleParse (lines $ B.unpack content)
if all isJust result
then return $ map fromJust result
else die "Could not parse world file."
where
safelyReadFile :: FilePath -> IO B.ByteString
safelyReadFile file = B.readFile file `catchIO` handler
where
handler e | isDoesNotExistError e = return B.empty
| otherwise = ioError e
instance Text WorldPkgInfo where
disp (WorldPkgInfo dep flags) = disp dep <+> dispFlags flags
where
dispFlags [] = Disp.empty
dispFlags fs = Disp.text "--flags="
<> Disp.doubleQuotes (flagAssToDoc fs)
flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc ->
(if not val then Disp.char '-'
else Disp.empty)
Disp.<> Disp.text fname
Disp.<+> flagAssDoc)
Disp.empty
parse = do
dep <- parse
Parse.skipSpaces
flagAss <- Parse.option [] parseFlagAssignment
return $ WorldPkgInfo dep flagAss
where
parseFlagAssignment :: Parse.ReadP r FlagAssignment
parseFlagAssignment = do
_ <- Parse.string "--flags"
Parse.skipSpaces
_ <- Parse.char '='
Parse.skipSpaces
inDoubleQuotes $ Parse.many1 flag
where
inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a
inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"')
flag = do
Parse.skipSpaces
val <- negative Parse.+++ positive
name <- ident
Parse.skipSpaces
return (FlagName name,val)
negative = do
_ <- Parse.char '-'
return False
positive = return True
ident :: Parse.ReadP r String
ident = do
-- First character must be a letter/digit to avoid flags
-- like "+-debug":
c <- Parse.satisfy Char.isAlphaNum
cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_'
|| ch == '-')
return (c:cs)
|
