content: -----------------------------------------------------------------------------
  -- |
  -- 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
  -- # etlas 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
  -- # etlas install world
  --
  -----------------------------------------------------------------------------
  module Distribution.Client.World (
      WorldPkgInfo(..),
      insert,
      delete,
      getContents,
    ) where
  
  import Distribution.Types.Dependency
  import Distribution.PackageDescription
           ( FlagAssignment, mkFlagName, unFlagName )
  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 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 verbosity 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 :: Verbosity -> FilePath -> IO [WorldPkgInfo]
  getContents verbosity world = do
    content <- safelyReadFile world
    let result = map simpleParse (lines $ B.unpack content)
    case sequence result of
      Nothing -> die' verbosity "Could not parse world file."
      Just xs -> return xs
    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 (\(fname,val) flagAssDoc ->
                               (if not val then Disp.char '-'
                                           else Disp.empty)
                               Disp.<> Disp.text (unFlagName 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 (mkFlagName 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)
  