cabal-install/src/Distribution/Client/SavedFlags.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2
   3 module Distribution.Client.SavedFlags
   4   ( readCommandFlags
   5   , writeCommandFlags
   6   , readSavedArgs
   7   , writeSavedArgs
   8   ) where
   9
  10 import Distribution.Client.Compat.Prelude
  11 import Prelude ()
  12
  13 import Distribution.Simple.Command
  14 import Distribution.Simple.UserHooks (Args)
  15 import Distribution.Simple.Utils
  16   ( createDirectoryIfMissingVerbose
  17   , unintersperse
  18   )
  19 import Distribution.Verbosity
  20
  21 import System.Directory (doesFileExist)
  22 import System.FilePath (takeDirectory)
  23
  24 writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO ()
  25 writeSavedArgs verbosity path args = do
  26   createDirectoryIfMissingVerbose
  27     (lessVerbose verbosity)
  28     True
  29     (takeDirectory path)
  30   writeFile path (intercalate "\0" args)
  31
  32 -- | Write command-line flags to a file, separated by null characters. This
  33 -- format is also suitable for the @xargs -0@ command. Using the null
  34 -- character also avoids the problem of escaping newlines or spaces,
  35 -- because unlike other whitespace characters, the null character is
  36 -- not valid in command-line arguments.
  37 writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO ()
  38 writeCommandFlags verbosity path command flags =
  39   writeSavedArgs verbosity path (commandShowOptions command flags)
  40
  41 readSavedArgs :: FilePath -> IO (Maybe [String])
  42 readSavedArgs path = do
  43   exists <- doesFileExist path
  44   if exists
  45     then fmap (Just . unintersperse '\0') (readFile path)
  46     else return Nothing
  47
  48 -- | Read command-line arguments, separated by null characters, from a file.
  49 -- Returns the default flags if the file does not exist.
  50 readCommandFlags :: FilePath -> CommandUI flags -> IO flags
  51 readCommandFlags path command = do
  52   savedArgs <- fmap (fromMaybe []) (readSavedArgs path)
  53   case (commandParseArgs command True savedArgs) of
  54     CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs)
  55     CommandList _ -> throwIO (SavedArgsErrorList savedArgs)
  56     CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs)
  57     CommandReadyToGo (mkFlags, _) ->
  58       return (mkFlags (commandDefaultFlags command))
  59
  60 -- -----------------------------------------------------------------------------
  61
  62 -- * Exceptions
  63
  64 -- -----------------------------------------------------------------------------
  65
  66 data SavedArgsError
  67   = SavedArgsErrorHelp Args
  68   | SavedArgsErrorList Args
  69   | SavedArgsErrorOther Args [String]
  70   deriving (Typeable)
  71
  72 instance Show SavedArgsError where
  73   show (SavedArgsErrorHelp args) =
  74     "unexpected flag '--help', saved command line was:\n"
  75       ++ intercalate " " args
  76   show (SavedArgsErrorList args) =
  77     "unexpected flag '--list-options', saved command line was:\n"
  78       ++ intercalate " " args
  79   show (SavedArgsErrorOther args errs) =
  80     "saved command line was:\n"
  81       ++ intercalate " " args
  82       ++ "\n"
  83       ++ "encountered errors:\n"
  84       ++ intercalate "\n" errs
  85
  86 instance Exception SavedArgsError