% Various utility functions that do not belong anywhere else.

\begin{code}

{-# OPTIONS -fffi #-}

module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand,
                    clarify_errors, prettyException,
                    putStrLnError, putDocLnError,
                    withCurrentDirectory, withUMask, askUser, stripCr,
                    showHexLen, add_to_error_loc,
                    isUnsupportedOperationError, isHardwareFaultError,
                    view_file, edit_file, promptChar, promptCharFancy, without_buffering,
                    formatPath ) where

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

import Numeric ( showHex )
import System ( ExitCode(..), getEnv )
import System.IO ( hFlush, hPutStrLn, stderr, stdout, stdin,
                   BufferMode ( NoBuffering ),
                   hLookAhead, hReady, hSetBuffering, hGetBuffering, hIsTerminalDevice )
import Control.Exception ( bracket )
import Data.Char ( toUpper )
import System.Directory ( setCurrentDirectory )
import Workaround ( getCurrentDirectory )
import Data.List ( group, sort )
import Control.Monad ( when )
import Exec ( exec_interactive )
import Printer ( Doc, hPutDocLn )
import Control.Exception ( bracket_ )
import Foreign.C.String ( CString, withCString )
import Foreign.C.Error ( throwErrno )
import Foreign.C.Types ( CInt )

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

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 :: Monad m => m ExitCode -> m ExitCode -> m ExitCode
a `ortryrunning` b = do ret <- a
                        if ret == ExitSuccess
                           then return ret
                           else b

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

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

\end{code}

\begin{code}
edit_file :: String -> IO ExitCode
edit_file 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
get_editor :: IO String
get_editor = getEnv "DARCS_EDITOR" `catchall`
             getEnv "DARCSEDITOR" `catchall`
             getEnv "VISUAL" `catchall`
             getEnv "EDITOR" `catchall` return "vi"
\end{code}

\begin{code}
view_file :: String -> IO ExitCode
view_file f = do
  viewer <- get_viewer
  exec_interactive viewer f
             `ortryrunning` exec_interactive "less" f
             `ortryrunning` exec_interactive "more" f
get_viewer :: IO String
get_viewer = getEnv "DARCS_PAGER" `catchall`
             getEnv "PAGER" `catchall` return "less"
\end{code}

\begin{code}
promptChar :: String -> [Char] -> IO Char
promptChar p chs = promptCharFancy p chs Nothing False 

promptCharFancy :: String -> [Char] -> Maybe Char -> Bool -> IO Char
promptCharFancy p chs md qmark_for_help = 
 do a <- without_buffering $ 
           do putStr $ p ++ " ["++ setDefault chs ++"]" ++ helpStr
              hFlush stdout
              getChar
    when (a /= '\n') $ putStr "\n" 
    case () of 
     _ | a `elem` chs                   -> return a
       | a == ' ' -> case md of Nothing -> tryAgain 
                                Just d  -> return d
       | a == '?' && qmark_for_help     -> return a 
       | otherwise                      -> tryAgain
 where 
 helpStr = if qmark_for_help then ", or ? for help: " else ""
 tryAgain = do putStrLn "Invalid response, try again!"
               promptCharFancy p chs md qmark_for_help 
 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 = 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
                            when is_ready $
                              do c <- hLookAhead stdin `catch` \_ -> return ' '
                                 when (c == '\n') $
                                   do getChar
                                      drop_returns
\end{code}

Code which was in the module RawMode before. Moved here to break cyclic imports

\begin{code}
#ifdef WIN32

get_raw_mode :: IO Bool
get_raw_mode = not `liftM` getEcho 0
  `catchall` return False -- getEcho sometimes fails when called from scripts

set_raw_mode :: Bool -> IO ()
set_raw_mode raw = setCooked 0 normal >> setEcho 0 normal
 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
\end{code}
