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

    {-# LANGUAGE CPP, ForeignFunctionInterface #-}

    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
                        -- * Tree filtering.
                       , 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 -- 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)

    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

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

    -- | Construct a filter from a list of AnchoredPaths, that will accept any path
    -- that is either a parent or a child of any of the listed paths, and discard
    -- everything else.
    filterPaths :: [AnchoredPath] -> AnchoredPath -> t -> Bool
    filterPaths files =
        \p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files

    -- | Same as 'filterPath', but for ordinary 'FilePath's (as opposed to
    -- AnchoredPath).
    filterFilePaths :: [FilePath] -> AnchoredPath -> t -> Bool
    filterFilePaths = filterPaths . map floatPath