{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
-- |
-- 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 Prelude (sequence)
import Distribution.Client.Compat.Prelude hiding (getContents)

import Distribution.Types.Dependency
import Distribution.Types.Flag
         ( FlagAssignment, unFlagAssignment
         , unFlagName, parsecFlagAssignmentNonEmpty )
import Distribution.Simple.Utils
         ( die', info, chattyTry, writeFileAtomic )
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp

import Data.List
         ( unionBy, deleteFirstsBy )
import System.IO.Error
         ( isDoesNotExistError )
import qualified Data.ByteString.Lazy.Char8 as B


data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment
  deriving (Int -> WorldPkgInfo -> ShowS
[WorldPkgInfo] -> ShowS
WorldPkgInfo -> String
(Int -> WorldPkgInfo -> ShowS)
-> (WorldPkgInfo -> String)
-> ([WorldPkgInfo] -> ShowS)
-> Show WorldPkgInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WorldPkgInfo] -> ShowS
$cshowList :: [WorldPkgInfo] -> ShowS
show :: WorldPkgInfo -> String
$cshow :: WorldPkgInfo -> String
showsPrec :: Int -> WorldPkgInfo -> ShowS
$cshowsPrec :: Int -> WorldPkgInfo -> ShowS
Show,WorldPkgInfo -> WorldPkgInfo -> Bool
(WorldPkgInfo -> WorldPkgInfo -> Bool)
-> (WorldPkgInfo -> WorldPkgInfo -> Bool) -> Eq WorldPkgInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WorldPkgInfo -> WorldPkgInfo -> Bool
$c/= :: WorldPkgInfo -> WorldPkgInfo -> Bool
== :: WorldPkgInfo -> WorldPkgInfo -> Bool
$c== :: WorldPkgInfo -> WorldPkgInfo -> Bool
Eq, (forall x. WorldPkgInfo -> Rep WorldPkgInfo x)
-> (forall x. Rep WorldPkgInfo x -> WorldPkgInfo)
-> Generic WorldPkgInfo
forall x. Rep WorldPkgInfo x -> WorldPkgInfo
forall x. WorldPkgInfo -> Rep WorldPkgInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep WorldPkgInfo x -> WorldPkgInfo
$cfrom :: forall x. WorldPkgInfo -> Rep WorldPkgInfo x
Generic)

-- | 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 :: Verbosity -> String -> [WorldPkgInfo] -> IO ()
insert = ([WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo])
-> Verbosity -> String -> [WorldPkgInfo] -> IO ()
modifyWorld (([WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo])
 -> Verbosity -> String -> [WorldPkgInfo] -> IO ())
-> ([WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo])
-> Verbosity
-> String
-> [WorldPkgInfo]
-> IO ()
forall a b. (a -> b) -> a -> b
$ (WorldPkgInfo -> WorldPkgInfo -> Bool)
-> [WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
unionBy WorldPkgInfo -> WorldPkgInfo -> Bool
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 :: Verbosity -> String -> [WorldPkgInfo] -> IO ()
delete = ([WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo])
-> Verbosity -> String -> [WorldPkgInfo] -> IO ()
modifyWorld (([WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo])
 -> Verbosity -> String -> [WorldPkgInfo] -> IO ())
-> ([WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo])
-> Verbosity
-> String
-> [WorldPkgInfo]
-> IO ()
forall a b. (a -> b) -> a -> b
$ ([WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo])
-> [WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((WorldPkgInfo -> WorldPkgInfo -> Bool)
-> [WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
deleteFirstsBy WorldPkgInfo -> WorldPkgInfo -> Bool
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 -> WorldPkgInfo -> Bool
equalUDep (WorldPkgInfo (Dependency PackageName
pkg1 VersionRange
_ NonEmptySet LibraryName
_) FlagAssignment
_)
          (WorldPkgInfo (Dependency PackageName
pkg2 VersionRange
_ NonEmptySet LibraryName
_) FlagAssignment
_) = PackageName
pkg1 PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
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 :: ([WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo])
-> Verbosity -> String -> [WorldPkgInfo] -> IO ()
modifyWorld [WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo]
_ Verbosity
_         String
_     []   = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
modifyWorld [WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo]
f Verbosity
verbosity String
world [WorldPkgInfo]
pkgs =
  String -> IO () -> IO ()
chattyTry String
"Error while updating world-file. " (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [WorldPkgInfo]
pkgsOldWorld <- Verbosity -> String -> IO [WorldPkgInfo]
getContents Verbosity
verbosity String
world
    -- Filter out packages that are not in the world file:
    let pkgsNewWorld :: [WorldPkgInfo]
pkgsNewWorld = (WorldPkgInfo -> WorldPkgInfo -> Bool)
-> [WorldPkgInfo] -> [WorldPkgInfo]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy WorldPkgInfo -> WorldPkgInfo -> Bool
equalUDep ([WorldPkgInfo] -> [WorldPkgInfo])
-> [WorldPkgInfo] -> [WorldPkgInfo]
forall a b. (a -> b) -> a -> b
$ [WorldPkgInfo] -> [WorldPkgInfo] -> [WorldPkgInfo]
f [WorldPkgInfo]
pkgs [WorldPkgInfo]
pkgsOldWorld
    -- 'Dependency' is not an Ord instance, so we need to check for
    -- equivalence the awkward way:
    if Bool -> Bool
not ((WorldPkgInfo -> Bool) -> [WorldPkgInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (WorldPkgInfo -> [WorldPkgInfo] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WorldPkgInfo]
pkgsOldWorld) [WorldPkgInfo]
pkgsNewWorld Bool -> Bool -> Bool
&&
            (WorldPkgInfo -> Bool) -> [WorldPkgInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (WorldPkgInfo -> [WorldPkgInfo] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WorldPkgInfo]
pkgsNewWorld) [WorldPkgInfo]
pkgsOldWorld)
      then do
        Verbosity -> String -> IO ()
info Verbosity
verbosity String
"Updating world file..."
        String -> ByteString -> IO ()
writeFileAtomic String
world (ByteString -> IO ()) -> (String -> ByteString) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [ (WorldPkgInfo -> String
forall a. Pretty a => a -> String
prettyShow WorldPkgInfo
pkg) | WorldPkgInfo
pkg <- [WorldPkgInfo]
pkgsNewWorld]
      else
        Verbosity -> String -> IO ()
info Verbosity
verbosity String
"World file is already up to date."


-- | Returns the content of the world file as a list
getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo]
getContents :: Verbosity -> String -> IO [WorldPkgInfo]
getContents Verbosity
verbosity String
world = do
  ByteString
content <- String -> IO ByteString
safelyReadFile String
world
  let result :: [Maybe WorldPkgInfo]
result = (String -> Maybe WorldPkgInfo) -> [String] -> [Maybe WorldPkgInfo]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe WorldPkgInfo
forall a. Parsec a => String -> Maybe a
simpleParsec (String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B.unpack ByteString
content)
  case [Maybe WorldPkgInfo] -> Maybe [WorldPkgInfo]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe WorldPkgInfo]
result of
    Maybe [WorldPkgInfo]
Nothing -> Verbosity -> String -> IO [WorldPkgInfo]
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"Could not parse world file."
    Just [WorldPkgInfo]
xs -> [WorldPkgInfo] -> IO [WorldPkgInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [WorldPkgInfo]
xs
  where
  safelyReadFile :: FilePath -> IO B.ByteString
  safelyReadFile :: String -> IO ByteString
safelyReadFile String
file = String -> IO ByteString
B.readFile String
file IO ByteString -> (IOException -> IO ByteString) -> IO ByteString
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` IOException -> IO ByteString
handler
    where
      handler :: IOException -> IO ByteString
handler IOException
e | IOException -> Bool
isDoesNotExistError IOException
e = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
                | Bool
otherwise             = IOException -> IO ByteString
forall a. IOException -> IO a
ioError IOException
e


instance Pretty WorldPkgInfo where
  pretty :: WorldPkgInfo -> Doc
pretty (WorldPkgInfo Dependency
dep FlagAssignment
flags) = Dependency -> Doc
forall a. Pretty a => a -> Doc
pretty Dependency
dep Doc -> Doc -> Doc
Disp.<+> [(FlagName, Bool)] -> Doc
dispFlags (FlagAssignment -> [(FlagName, Bool)]
unFlagAssignment FlagAssignment
flags)
    where
      dispFlags :: [(FlagName, Bool)] -> Doc
dispFlags [] = Doc
Disp.empty
      dispFlags [(FlagName, Bool)]
fs = String -> Doc
Disp.text String
"--flags="
                  Doc -> Doc -> Doc
<<>> Doc -> Doc
Disp.doubleQuotes ([(FlagName, Bool)] -> Doc
flagAssToDoc [(FlagName, Bool)]
fs)
      flagAssToDoc :: [(FlagName, Bool)] -> Doc
flagAssToDoc = ((FlagName, Bool) -> Doc -> Doc)
-> Doc -> [(FlagName, Bool)] -> Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(FlagName
fname,Bool
val) Doc
flagAssDoc ->
                             (if Bool -> Bool
not Bool
val then Char -> Doc
Disp.char Char
'-'
                                         else Char -> Doc
Disp.char Char
'+')
                             Doc -> Doc -> Doc
<<>> String -> Doc
Disp.text (FlagName -> String
unFlagName FlagName
fname)
                             Doc -> Doc -> Doc
Disp.<+> Doc
flagAssDoc)
                           Doc
Disp.empty

instance Parsec WorldPkgInfo where
  parsec :: m WorldPkgInfo
parsec = do
      Dependency
dep <- m Dependency
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
      m ()
forall (m :: * -> *). CharParsing m => m ()
P.spaces
      FlagAssignment
flagAss <- FlagAssignment -> m FlagAssignment -> m FlagAssignment
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option FlagAssignment
forall a. Monoid a => a
mempty m FlagAssignment
forall (m :: * -> *). CabalParsing m => m FlagAssignment
parseFlagAssignment
      WorldPkgInfo -> m WorldPkgInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (WorldPkgInfo -> m WorldPkgInfo) -> WorldPkgInfo -> m WorldPkgInfo
forall a b. (a -> b) -> a -> b
$ Dependency -> FlagAssignment -> WorldPkgInfo
WorldPkgInfo Dependency
dep FlagAssignment
flagAss
    where
      parseFlagAssignment :: CabalParsing m => m FlagAssignment
      parseFlagAssignment :: m FlagAssignment
parseFlagAssignment = do
          String
_ <- String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"--flags="
          m FlagAssignment -> m FlagAssignment
forall a. m a -> m a
inDoubleQuotes m FlagAssignment
forall (m :: * -> *). CabalParsing m => m FlagAssignment
parsecFlagAssignmentNonEmpty
        where
          inDoubleQuotes :: m a -> m a
inDoubleQuotes = m Char -> m Char -> m a -> m a
forall (m :: * -> *) bra ket a.
Applicative m =>
m bra -> m ket -> m a -> m a
P.between (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'"') (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'"')