never executed always true always false
1 {-# LANGUAGE DeriveGeneric #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module : Distribution.Client.World
5 -- Copyright : (c) Peter Robinson 2009
6 -- License : BSD-like
7 --
8 -- Maintainer : thaldyron@gmail.com
9 -- Stability : provisional
10 -- Portability : portable
11 --
12 -- Interface to the world-file that contains a list of explicitly
13 -- requested packages. Meant to be imported qualified.
14 --
15 -- A world file entry stores the package-name, package-version, and
16 -- user flags.
17 -- For example, the entry generated by
18 -- # cabal install stm-io-hooks --flags="-debug"
19 -- looks like this:
20 -- # stm-io-hooks -any --flags="-debug"
21 -- To rebuild/upgrade the packages in world (e.g. when updating the compiler)
22 -- use
23 -- # cabal install world
24 --
25 -----------------------------------------------------------------------------
26 module Distribution.Client.World (
27 WorldPkgInfo(..),
28 insert,
29 delete,
30 getContents,
31 ) where
32
33 import Prelude (sequence)
34 import Distribution.Client.Compat.Prelude hiding (getContents)
35
36 import Distribution.Types.Dependency
37 import Distribution.Types.Flag
38 ( FlagAssignment, unFlagAssignment
39 , unFlagName, parsecFlagAssignmentNonEmpty )
40 import Distribution.Simple.Utils
41 ( die', info, chattyTry, writeFileAtomic )
42 import qualified Distribution.Compat.CharParsing as P
43 import qualified Text.PrettyPrint as Disp
44
45 import Data.List
46 ( unionBy, deleteFirstsBy )
47 import System.IO.Error
48 ( isDoesNotExistError )
49 import qualified Data.ByteString.Lazy.Char8 as B
50
51
52 data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment
53 deriving (Show,Eq, Generic)
54
55 -- | Adds packages to the world file; creates the file if it doesn't
56 -- exist yet. Version constraints and flag assignments for a package are
57 -- updated if already present. IO errors are non-fatal.
58 insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()
59 insert = modifyWorld $ unionBy equalUDep
60
61 -- | Removes packages from the world file.
62 -- Note: Currently unused as there is no mechanism in Cabal (yet) to
63 -- handle uninstalls. IO errors are non-fatal.
64 delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()
65 delete = modifyWorld $ flip (deleteFirstsBy equalUDep)
66
67 -- | WorldPkgInfo values are considered equal if they refer to
68 -- the same package, i.e., we don't care about differing versions or flags.
69 equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool
70 equalUDep (WorldPkgInfo (Dependency pkg1 _ _) _)
71 (WorldPkgInfo (Dependency pkg2 _ _) _) = pkg1 == pkg2
72
73 -- | Modifies the world file by applying an update-function ('unionBy'
74 -- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of
75 -- packages. IO errors are considered non-fatal.
76 modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo]
77 -> [WorldPkgInfo])
78 -- ^ Function that defines how
79 -- the list of user packages are merged with
80 -- existing world packages.
81 -> Verbosity
82 -> FilePath -- ^ Location of the world file
83 -> [WorldPkgInfo] -- ^ list of user supplied packages
84 -> IO ()
85 modifyWorld _ _ _ [] = return ()
86 modifyWorld f verbosity world pkgs =
87 chattyTry "Error while updating world-file. " $ do
88 pkgsOldWorld <- getContents verbosity world
89 -- Filter out packages that are not in the world file:
90 let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld
91 -- 'Dependency' is not an Ord instance, so we need to check for
92 -- equivalence the awkward way:
93 if not (all (`elem` pkgsOldWorld) pkgsNewWorld &&
94 all (`elem` pkgsNewWorld) pkgsOldWorld)
95 then do
96 info verbosity "Updating world file..."
97 writeFileAtomic world . B.pack $ unlines
98 [ (prettyShow pkg) | pkg <- pkgsNewWorld]
99 else
100 info verbosity "World file is already up to date."
101
102
103 -- | Returns the content of the world file as a list
104 getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo]
105 getContents verbosity world = do
106 content <- safelyReadFile world
107 let result = map simpleParsec (lines $ B.unpack content)
108 case sequence result of
109 Nothing -> die' verbosity "Could not parse world file."
110 Just xs -> return xs
111 where
112 safelyReadFile :: FilePath -> IO B.ByteString
113 safelyReadFile file = B.readFile file `catchIO` handler
114 where
115 handler e | isDoesNotExistError e = return B.empty
116 | otherwise = ioError e
117
118
119 instance Pretty WorldPkgInfo where
120 pretty (WorldPkgInfo dep flags) = pretty dep Disp.<+> dispFlags (unFlagAssignment flags)
121 where
122 dispFlags [] = Disp.empty
123 dispFlags fs = Disp.text "--flags="
124 <<>> Disp.doubleQuotes (flagAssToDoc fs)
125 flagAssToDoc = foldr (\(fname,val) flagAssDoc ->
126 (if not val then Disp.char '-'
127 else Disp.char '+')
128 <<>> Disp.text (unFlagName fname)
129 Disp.<+> flagAssDoc)
130 Disp.empty
131
132 instance Parsec WorldPkgInfo where
133 parsec = do
134 dep <- parsec
135 P.spaces
136 flagAss <- P.option mempty parseFlagAssignment
137 return $ WorldPkgInfo dep flagAss
138 where
139 parseFlagAssignment :: CabalParsing m => m FlagAssignment
140 parseFlagAssignment = do
141 _ <- P.string "--flags="
142 inDoubleQuotes parsecFlagAssignmentNonEmpty
143 where
144 inDoubleQuotes = P.between (P.char '"') (P.char '"')