-- Various utility functions that do not belong anywhere else.

{-# LANGUAGE CPP, ForeignFunctionInterface #-}

module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand,
                     clarify_errors, prettyException, prettyError,
                    putStrLnError, putDocLnError,
                    withCurrentDirectory,
                    withUMask, askUser, stripCr,
                    showHexLen, add_to_error_loc,
                    maybeGetEnv, firstNotBlank, firstJustM, firstJustIO,
                    isUnsupportedOperationError, isHardwareFaultError,
                    get_viewer, edit_file, promptYorn, promptCharFancy,
                    environmentHelpEditor, environmentHelpPager,
                    formatPath ) 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 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 -- err can only be isDoesNotExist


-- |The firstJustM returns the first Just entry in a list of monadic operations.  This is close to
--  `listToMaybe `fmap` sequence`, but the sequence operator evaluates all monadic members of the
--  list before passing it along (i.e. sequence is strict).  The firstJustM is lazy in that list
--  member monads are only evaluated up to the point where the first Just entry is obtained.
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)

-- |The firstJustIO is a slight modification to firstJustM: the
--  entries in the list must be IO monad operations and the
--  firstJustIO will silently turn any monad call that throws an
--  exception into Nothing, basically causing it to be ignored.
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

prettyError :: IOError -> String
prettyError e | isUserError e = ioeGetErrorString e
              | otherwise = show e

-- | Given two shell commands as arguments, execute the former.  The
-- latter is then executed if the former failed because the executable
-- wasn't found (code 127), wasn't executable (code 126) or some other
-- exception occurred.  Other failures (such as the user holding ^C)
-- do not cause the second command to be tried.
ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode
a `ortryrunning` b = do
  ret <- try a
  case ret of
    (Right (ExitFailure 126)) -> b -- command not executable
    (Right (ExitFailure 127)) -> b -- command not found
    (Right x) -> return x          -- legitimate success/failure
    (Left _) -> b                  -- an exception

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
            -- Return the input as encoded, 8-bit Chars (same as the
            -- non-Haskeline backend).
                        >>= fmap B.unpack . encode

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

-- |Returns Just l where l is first non-blank string in input array; Nothing if no non-blank entries
firstNotBlank :: [String] -> Maybe String
firstNotBlank = listToMaybe . filter (not . null)


-- 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


edit_file :: FilePathLike p => p -> IO ExitCode
edit_file ff = do
  ed <- get_editor
  old_content <- file_content
  ec <- 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
  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

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