% Various utility functions that do not belong anywhere else.

\begin{code}

{-# OPTIONS -fffi #-}

module DarcsUtils ( catchall, ortryrunning, bug, bugDoc, nubsort,
                    clarify_errors, prettyException,
                    putStrLnError, putDocLnError,
                    withCurrentDirectory, withUMask, askUser, stripCr,
                    showHexLen, add_to_error_loc,
                    isUnsupportedOperationError, isHardwareFaultError,
                    formatPath ) where

import Control.Exception ( Exception(IOException) )
import GHC.IOBase ( IOException(ioe_location),
                    IOErrorType(UnsupportedOperation, HardwareFault) )
import System.IO.Error ( isUserError, ioeGetErrorType, ioeGetErrorString )

import Numeric ( showHex )
import System ( ExitCode(..) )
import System.IO ( hFlush, hPutStrLn, stderr, stdout )
import Control.Exception ( bracket )
import Directory ( setCurrentDirectory )
import Workaround ( getCurrentDirectory )
import List ( group, sort )
import Monad ( when )
import Printer ( Doc, errorDoc, hPutDocLn, text, ($$) )
import Control.Exception ( bracket_ )
import Foreign.C.String ( CString, withCString )
import Foreign.C.Error ( throwErrno )
import Foreign.C.Types ( CInt )

#ifdef WIN32
import Monad ( liftM )
#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 `catch` (\_ -> b)

clarify_errors :: IO a -> String -> IO a
clarify_errors a e = a `catch` (\x -> fail $ unlines [show x,e])

prettyException :: Control.Exception.Exception -> String
prettyException (IOException e) | isUserError e = ioeGetErrorString e
prettyException e = show e

ortryrunning :: Monad m => m ExitCode -> m ExitCode -> m ExitCode
a `ortryrunning` b = do ret <- a
                        if ret == ExitSuccess
                           then return ret
                           else b

bug :: String -> a
bug s = error $ "bug in darcs!\n" ++ s ++
                "\nPlease report this to bugs@darcs.net," ++
                "\nIf possible include the output of 'darcs --exact-version'."

bugDoc :: Doc -> a
bugDoc s = errorDoc $ text "bug in darcs!"
                   $$ s
                   $$ text "Please report this to bugs@darcs.net"
                   $$ text "If possible include the output of 'darcs --exact-version'."

putStrLnError :: String -> IO ()
putStrLnError = hPutStrLn stderr

putDocLnError :: Doc -> IO ()
putDocLnError = hPutDocLn stderr

withCurrentDirectory :: FilePath -> IO a -> IO a
withCurrentDirectory name m =
    bracket
        (do cwd <- getCurrentDirectory
            when (name /= "") (setCurrentDirectory name)
            return cwd)
        (\oldwd -> do setCurrentDirectory oldwd)
        (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 = do putStr prompt
                    hFlush stdout
#ifndef WIN32
                    getLine
#else
                    liftM stripCr getLine
#endif

stripCr :: String -> String
stripCr ""     = ""
stripCr "\r"   = ""
stripCr (c:cs) = c : stripCr cs

-- Format a path for screen output,
-- so that the user sees where the path begins and ends.
-- Could (should?) also warn about unprintable characters here.
formatPath :: String -> String
formatPath path = "\"" ++ quote path ++ "\""
    where quote "" = ""
          quote (c:cs) = if c=='\\' || c=='"'
                         then '\\':c:quote cs
                         else c:quote cs

nubsort :: Ord a => [a] -> [a]
nubsort = map head . group . sort

\end{code}