module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand,
clarify_errors, prettyException,
putStrLnError, putDocLnError,
withCurrentDirectory,
withUMask, askUser, stripCr,
showHexLen, add_to_error_loc,
maybeGetEnv, firstNotBlank, firstJustM, firstJustIO,
isUnsupportedOperationError, isHardwareFaultError,
get_viewer, edit_file, promptYorn, promptCharFancy, without_buffering,
formatPath ) where
import Prelude hiding ( catch )
import Control.Exception ( bracket, bracket_, catch, Exception(IOException), throwIO, try, throw, ioErrors )
import Control.Concurrent ( newEmptyMVar, takeMVar, putMVar, forkIO )
#if !defined(WIN32) || __GLASGOW_HASKELL__>=609
import Control.Concurrent ( threadWaitRead )
#endif
import GHC.IOBase ( IOException(ioe_location),
IOErrorType(UnsupportedOperation, HardwareFault) )
import System.IO.Error ( isUserError, ioeGetErrorType, ioeGetErrorString,
isEOFError )
import Darcs.SignalHandler ( catchNonSignal )
import Numeric ( showHex )
import System.Exit ( ExitCode(..) )
import System.Environment ( getEnv )
import System.IO ( hFlush, hPutStrLn, stderr, stdout, stdin,
BufferMode ( NoBuffering ),
hLookAhead, hReady, hSetBuffering, hGetBuffering, hIsTerminalDevice )
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 )
#ifdef HAVE_HASKELINE
import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine )
#endif
#ifdef WIN32
import System.Posix.Internals ( getEcho, setCooked, setEcho )
#endif
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)
clarify_errors :: IO a -> String -> IO a
clarify_errors 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
ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode
a `ortryrunning` b = do ret <- try a
case ret of
(Right ExitSuccess) -> return ExitSuccess
_ -> 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
withThread :: IO a -> IO a
withThread j = do m <- newEmptyMVar
forkIO (runJob m)
takeMVar m >>= either throwIO return
where runJob m = (j >>= putMVar m . Right) `catch` (putMVar m . Left)
askUser :: String -> IO String
#ifdef HAVE_HASKELINE
askUser prompt = withoutProgress $ runInputT defaultSettings (getInputLine prompt)
>>= maybe (error "askUser: unexpected end of input") return
#else
askUser prompt = withThread $ withoutProgress $ do putStr prompt
hFlush stdout
waitForStdin
#ifndef WIN32
getLine
#else
stripCr `fmap` getLine
#endif
#endif
waitForStdin :: IO ()
#ifdef WIN32
#if __GLASGOW_HASKELL__ >= 609
waitForStdin = threadWaitRead 0
#else
waitForStdin = return ()
#endif
#else
waitForStdin = threadWaitRead 0
#endif
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
let f = toFilePath ff
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"
get_viewer :: IO String
get_viewer = getEnv "DARCS_PAGER" `catchall`
getEnv "PAGER" `catchall` return "less"
promptYorn :: [Char] -> IO Char
promptYorn p = promptCharFancy p "yn" Nothing []
promptCharFancy :: String -> [Char] -> Maybe Char -> [Char] -> IO Char
promptCharFancy p chs md help_chs =
do a <- withThread $ without_buffering $
do putStr $ p ++ " ["++ setDefault chs ++"]" ++ helpStr
hFlush stdout
waitForStdin
c <- getChar
#ifdef WIN32
e <- get_raw_mode
when e $ putChar c
#endif
return c
when (a /= '\n') $ putStr "\n"
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
where
helpStr = case help_chs of
[] -> ""
(h:_) -> ", or " ++ (h:" for help: ")
tryAgain = do putStrLn "Invalid response, try again!"
promptCharFancy p chs md help_chs
setDefault s = case md of Nothing -> s
Just d -> map (setUpper d) s
setUpper d c = if d == c then toUpper c else c
without_buffering :: IO a -> IO a
without_buffering job = withoutProgress $ do
bracket nobuf rebuf $ \_ -> job
where nobuf = do is_term <- hIsTerminalDevice stdin
bi <- hGetBuffering stdin
raw <- get_raw_mode
when is_term $ do hSetBuffering stdin NoBuffering `catch` \_ -> return ()
set_raw_mode True
return (bi,raw)
rebuf (bi,raw) = do is_term <- hIsTerminalDevice stdin
#if SYS == windows
buffers <- hGetBuffering stdin
hSetBuffering stdin NoBuffering `catch` \_ -> return ()
drop_returns
hSetBuffering stdin buffers `catch` \_ -> return ()
#else
drop_returns
#endif
when is_term $ do hSetBuffering stdin bi `catch` \_ -> return ()
set_raw_mode raw
drop_returns = do is_ready <- hReady stdin `catch` \ e ->
case ioErrors e of
Just x -> if isEOFError x
then return True
else throw e
_ -> throw e
when is_ready $
do waitForStdin
c <- hLookAhead stdin `catch` \_ -> return ' '
when (c == '\n') $
do getChar
drop_returns
#ifdef WIN32
get_raw_mode :: IO Bool
get_raw_mode = not `fmap` getEcho 0
`catchall` return False
set_raw_mode :: Bool -> IO ()
set_raw_mode raw = (setCooked 0 normal >> setEcho 0 normal)
`catchall` return ()
where normal = not raw
#else
get_raw_mode :: IO Bool
get_raw_mode = return False
set_raw_mode :: Bool -> IO ()
set_raw_mode _ = return ()
#endif