module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand,
clarifyErrors, prettyException, prettyError,
putStrLnError, putDocLnError,
withCurrentDirectory,
withUMask, askUser, stripCr,
showHexLen, add_to_error_loc,
maybeGetEnv, firstNotBlank, firstJustM, firstJustIO,
isUnsupportedOperationError, isHardwareFaultError,
get_viewer, edit_file, run_editor,
promptYorn, promptCharFancy,
environmentHelpEditor, environmentHelpPager,
formatPath
, filterFilePaths, filterPaths
) where
import Prelude hiding ( catch )
import Control.Exception ( bracket, bracket_, catch, Exception(IOException), try )
import GHC.IOBase ( IOException(ioe_location),
IOErrorType(UnsupportedOperation, HardwareFault) )
import System.IO.Error ( isUserError, ioeGetErrorType, ioeGetErrorString )
import Darcs.SignalHandler ( catchNonSignal )
import Numeric ( showHex )
import System.Directory ( doesFileExist )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getEnv )
import System.IO ( hPutStrLn, stderr )
import Data.Char ( toUpper )
import Darcs.RepoPath ( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath )
import Data.Maybe ( listToMaybe, isJust )
import Data.List ( group, sort )
import Control.Monad ( when )
import Exec ( exec_interactive )
import Printer ( Doc, hPutDocLn )
import Foreign.C.String ( CString, withCString )
import Foreign.C.Error ( throwErrno )
import Foreign.C.Types ( CInt )
import Progress ( withoutProgress )
import Storage.Hashed.AnchoredPath( AnchoredPath, isPrefix, floatPath )
import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine,
getInputChar, outputStrLn )
import System.Console.Haskeline.Encoding ( encode )
import qualified Data.ByteString as B ( readFile )
import qualified Data.ByteString.Char8 as B ( unpack )
showHexLen :: (Integral a) => Int -> a -> String
showHexLen n x = let s = showHex x ""
in replicate (n length s) ' ' ++ s
add_to_error_loc :: Exception -> String -> Exception
add_to_error_loc (IOException ioe) s
= IOException $ ioe { ioe_location = s ++ ": " ++ ioe_location ioe }
add_to_error_loc e _ = e
isUnsupportedOperationError :: IOError -> Bool
isUnsupportedOperationError = isUnsupportedOperationErrorType . ioeGetErrorType
isUnsupportedOperationErrorType :: IOErrorType -> Bool
isUnsupportedOperationErrorType UnsupportedOperation = True
isUnsupportedOperationErrorType _ = False
isHardwareFaultError :: IOError -> Bool
isHardwareFaultError = isHardwareFaultErrorType . ioeGetErrorType
isHardwareFaultErrorType :: IOErrorType -> Bool
isHardwareFaultErrorType HardwareFault = True
isHardwareFaultErrorType _ = False
catchall :: IO a -> IO a -> IO a
a `catchall` b = a `catchNonSignal` (\_ -> b)
maybeGetEnv :: String -> IO (Maybe String)
maybeGetEnv s = (getEnv s >>= return.Just) `catchall` return Nothing
firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a)
firstJustM [] = return Nothing
firstJustM (e:es) = e >>= (\v -> if isJust v then return v else firstJustM es)
firstJustIO :: [IO (Maybe a)] -> IO (Maybe a)
firstJustIO = firstJustM . map (\o -> o `catchall` return Nothing)
clarifyErrors :: IO a -> String -> IO a
clarifyErrors a e = a `catch` (\x -> fail $ unlines [prettyException x,e])
prettyException :: Control.Exception.Exception -> String
prettyException (IOException e) | isUserError e = ioeGetErrorString e
prettyException e = show e
prettyError :: IOError -> String
prettyError e | isUserError e = ioeGetErrorString e
| otherwise = show e
ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode
a `ortryrunning` b = do
ret <- try a
case ret of
(Right (ExitFailure 126)) -> b
(Right (ExitFailure 127)) -> b
(Right x) -> return x
(Left _) -> b
putStrLnError :: String -> IO ()
putStrLnError = hPutStrLn stderr
putDocLnError :: Doc -> IO ()
putDocLnError = hPutDocLn stderr
withCurrentDirectory :: FilePathLike p => p -> IO a -> IO a
withCurrentDirectory name m =
bracket
(do cwd <- getCurrentDirectory
when (toFilePath name /= "") (setCurrentDirectory name)
return cwd)
(\oldwd -> setCurrentDirectory oldwd `catchall` return ())
(const m)
foreign import ccall unsafe "umask.h set_umask" set_umask
:: CString -> IO CInt
foreign import ccall unsafe "umask.h reset_umask" reset_umask
:: CInt -> IO CInt
withUMask :: String -> IO a -> IO a
withUMask umask job =
do rc <-withCString umask set_umask
when (rc < 0) (throwErrno "Couldn't set umask")
bracket_
(return ())
(reset_umask rc)
job
askUser :: String -> IO String
askUser prompt = withoutProgress $ runInputT defaultSettings $
getInputLine prompt
>>= maybe (error "askUser: unexpected end of input") return
>>= fmap B.unpack . encode
stripCr :: String -> String
stripCr "" = ""
stripCr "\r" = ""
stripCr (c:cs) = c : stripCr cs
firstNotBlank :: [String] -> Maybe String
firstNotBlank = listToMaybe . filter (not . null)
formatPath :: String -> String
formatPath path = "\"" ++ quote path ++ "\""
where quote "" = ""
quote (c:cs) = if c=='\\' || c=='"'
then '\\':c:quote cs
else c:quote cs
breakCommand :: String -> (String, [String])
breakCommand s = case words s of
(arg0:args) -> (arg0,args)
[] -> (s,[])
nubsort :: Ord a => [a] -> [a]
nubsort = map head . group . sort
edit_file :: FilePathLike p => p -> IO ExitCode
edit_file ff = do
old_content <- file_content
ec <- run_editor f
new_content <- file_content
when (new_content == old_content) $ do
yorn <- promptYorn "File content did not change. Continue anyway?"
when (yorn == 'n') $ do putStrLn "Aborted."
exitWith ExitSuccess
return ec
where f = toFilePath ff
file_content = do
exists <- doesFileExist f
if exists then do content <- B.readFile f
return $ Just content
else return Nothing
run_editor :: FilePath -> IO ExitCode
run_editor f = do
ed <- get_editor
exec_interactive ed f
`ortryrunning` exec_interactive "emacs" f
`ortryrunning` exec_interactive "emacs -nw" f
`ortryrunning` exec_interactive "nano" f
#ifdef WIN32
`ortryrunning` exec_interactive "edit" f
#endif
get_editor :: IO String
get_editor = getEnv "DARCS_EDITOR" `catchall`
getEnv "DARCSEDITOR" `catchall`
getEnv "VISUAL" `catchall`
getEnv "EDITOR" `catchall` return "vi"
environmentHelpEditor :: ([String], [String])
environmentHelpEditor = (["DARCS_EDITOR", "DARCSEDITOR", "VISUAL", "EDITOR"],[
"To edit a patch description of email comment, Darcs will invoke an",
"external editor. Your preferred editor can be set as any of the",
"environment variables $DARCS_EDITOR, $DARCSEDITOR, $VISUAL or $EDITOR.",
"If none of these are set, vi(1) is used. If vi crashes or is not",
"found in your PATH, emacs, emacs -nw, nano and (on Windows) edit are",
"each tried in turn."])
get_viewer :: IO String
get_viewer = getEnv "DARCS_PAGER" `catchall`
getEnv "PAGER" `catchall` return "less"
environmentHelpPager :: ([String], [String])
environmentHelpPager = (["DARCS_PAGER", "PAGER"],[
"Darcs will sometimes invoke a pager if it deems output to be too long",
"to fit onscreen. Darcs will use the pager specified by $DARCS_PAGER",
"or $PAGER. If neither are set, `less' will be used."])
promptYorn :: [Char] -> IO Char
promptYorn p = promptCharFancy p "yn" Nothing []
promptCharFancy :: String -> [Char] -> Maybe Char -> [Char] -> IO Char
promptCharFancy p chs md help_chs = withoutProgress $ runInputT defaultSettings $
loopChar
where
loopChar = do
let prompt = p ++ " [" ++ setDefault chs ++ "]" ++ helpStr
a <- getInputChar prompt >>= maybe (error "promptCharFancy: unexpected end of input")
return
case () of
_ | a `elem` chs -> return a
| a == ' ' -> case md of Nothing -> tryAgain
Just d -> return d
| a `elem` help_chs -> return a
| otherwise -> tryAgain
helpStr = case help_chs of
[] -> ""
(h:_) -> ", or " ++ (h:" for help: ")
tryAgain = do outputStrLn "Invalid response, try again!"
loopChar
setDefault s = case md of Nothing -> s
Just d -> map (setUpper d) s
setUpper d c = if d == c then toUpper c else c
filterPaths :: [AnchoredPath] -> AnchoredPath -> t -> Bool
filterPaths files =
\p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files
filterFilePaths :: [FilePath] -> AnchoredPath -> t -> Bool
filterFilePaths = filterPaths . map floatPath