2010-11-08 19:15:21 +00:00
|
|
|
{- git-annex output messages
|
|
|
|
-
|
|
|
|
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
2011-09-01 19:16:31 +00:00
|
|
|
module Messages (
|
|
|
|
showStart,
|
|
|
|
showNote,
|
|
|
|
showAction,
|
|
|
|
showProgress,
|
|
|
|
showSideAction,
|
|
|
|
showOutput,
|
|
|
|
showLongNote,
|
|
|
|
showEndOk,
|
|
|
|
showEndFail,
|
|
|
|
showEndResult,
|
|
|
|
showErr,
|
|
|
|
warning,
|
|
|
|
indent,
|
2011-09-02 20:44:04 +00:00
|
|
|
maybeShowJSON,
|
2011-09-01 19:16:31 +00:00
|
|
|
setupConsole
|
|
|
|
) where
|
2010-11-08 19:15:21 +00:00
|
|
|
|
2011-09-02 20:44:04 +00:00
|
|
|
import Text.JSON
|
2010-11-08 19:15:21 +00:00
|
|
|
|
2011-10-04 02:24:57 +00:00
|
|
|
import Common
|
2010-11-08 19:15:21 +00:00
|
|
|
import Types
|
|
|
|
import qualified Annex
|
2011-09-01 19:16:31 +00:00
|
|
|
import qualified Messages.JSON as JSON
|
2010-11-08 19:15:21 +00:00
|
|
|
|
|
|
|
showStart :: String -> String -> Annex ()
|
2011-10-11 18:43:45 +00:00
|
|
|
showStart command file = handle (JSON.start command file) $
|
|
|
|
flushed $ putStr $ command ++ " " ++ file ++ " "
|
2010-11-08 19:15:21 +00:00
|
|
|
|
|
|
|
showNote :: String -> Annex ()
|
2011-10-11 18:43:45 +00:00
|
|
|
showNote s = handle (JSON.note s) $
|
|
|
|
flushed $ putStr $ "(" ++ s ++ ") "
|
2011-07-19 18:07:23 +00:00
|
|
|
|
|
|
|
showAction :: String -> Annex ()
|
|
|
|
showAction s = showNote $ s ++ "..."
|
2010-11-08 19:15:21 +00:00
|
|
|
|
|
|
|
showProgress :: Annex ()
|
2011-10-11 18:43:45 +00:00
|
|
|
showProgress = handle q $
|
|
|
|
flushed $ putStr "."
|
2011-07-19 18:07:23 +00:00
|
|
|
|
|
|
|
showSideAction :: String -> Annex ()
|
2011-10-11 18:43:45 +00:00
|
|
|
showSideAction s = handle q $
|
|
|
|
putStrLn $ "(" ++ s ++ "...)"
|
2011-07-19 18:07:23 +00:00
|
|
|
|
|
|
|
showOutput :: Annex ()
|
2011-10-11 18:43:45 +00:00
|
|
|
showOutput = handle q $
|
|
|
|
putStr "\n"
|
2010-11-08 19:15:21 +00:00
|
|
|
|
|
|
|
showLongNote :: String -> Annex ()
|
2011-10-11 18:43:45 +00:00
|
|
|
showLongNote s = handle (JSON.note s) $
|
|
|
|
putStrLn $ '\n' : indent s
|
2011-01-27 00:30:07 +00:00
|
|
|
|
2010-11-08 19:15:21 +00:00
|
|
|
showEndOk :: Annex ()
|
2011-09-01 19:16:31 +00:00
|
|
|
showEndOk = showEndResult True
|
2010-11-08 19:15:21 +00:00
|
|
|
|
|
|
|
showEndFail :: Annex ()
|
2011-09-01 19:16:31 +00:00
|
|
|
showEndFail = showEndResult False
|
2010-11-08 19:15:21 +00:00
|
|
|
|
2011-05-15 16:25:58 +00:00
|
|
|
showEndResult :: Bool -> Annex ()
|
2011-09-01 19:16:31 +00:00
|
|
|
showEndResult b = handle (JSON.end b) $ putStrLn msg
|
|
|
|
where
|
|
|
|
msg
|
|
|
|
| b = "ok"
|
|
|
|
| otherwise = "failed"
|
2011-05-15 16:25:58 +00:00
|
|
|
|
2010-11-08 19:15:21 +00:00
|
|
|
showErr :: (Show a) => a -> Annex ()
|
2011-09-06 17:46:08 +00:00
|
|
|
showErr e = warning' $ "git-annex: " ++ show e
|
2010-11-08 19:15:21 +00:00
|
|
|
|
|
|
|
warning :: String -> Annex ()
|
2011-09-06 17:46:08 +00:00
|
|
|
warning w = warning' (indent w)
|
|
|
|
|
|
|
|
warning' :: String -> Annex ()
|
|
|
|
warning' w = do
|
2011-09-01 19:16:31 +00:00
|
|
|
handle q $ putStr "\n"
|
2011-07-19 18:07:23 +00:00
|
|
|
liftIO $ do
|
|
|
|
hFlush stdout
|
2011-09-06 17:46:08 +00:00
|
|
|
hPutStrLn stderr w
|
2011-01-27 00:30:07 +00:00
|
|
|
|
|
|
|
indent :: String -> String
|
|
|
|
indent s = join "\n" $ map (\l -> " " ++ l) $ lines s
|
2011-02-10 18:21:44 +00:00
|
|
|
|
2011-03-12 19:30:17 +00:00
|
|
|
{- By default, haskell honors the user's locale in its output to stdout
|
|
|
|
- and stderr. While that's great for proper unicode support, for git-annex
|
|
|
|
- all that's really needed is the ability to display simple messages
|
|
|
|
- (currently untranslated), and importantly, to display filenames exactly
|
|
|
|
- as they are written on disk, no matter what their encoding. So, force
|
|
|
|
- raw mode.
|
|
|
|
-
|
|
|
|
- NB: Once git-annex gets localized, this will need a rethink. -}
|
|
|
|
setupConsole :: IO ()
|
|
|
|
setupConsole = do
|
|
|
|
hSetBinaryMode stdout True
|
|
|
|
hSetBinaryMode stderr True
|
2011-09-01 19:16:31 +00:00
|
|
|
|
|
|
|
handle :: IO () -> IO () -> Annex ()
|
|
|
|
handle json normal = do
|
|
|
|
output <- Annex.getState Annex.output
|
|
|
|
case output of
|
|
|
|
Annex.NormalOutput -> liftIO normal
|
|
|
|
Annex.QuietOutput -> q
|
|
|
|
Annex.JSONOutput -> liftIO json
|
|
|
|
|
2011-09-02 20:44:04 +00:00
|
|
|
{- Shows a JSON value only when in json mode. -}
|
|
|
|
maybeShowJSON :: JSON a => [(String, a)] -> Annex ()
|
|
|
|
maybeShowJSON v = handle (JSON.add v) q
|
|
|
|
|
2011-09-01 19:16:31 +00:00
|
|
|
q :: Monad m => m ()
|
|
|
|
q = return ()
|
2011-10-11 18:43:45 +00:00
|
|
|
|
|
|
|
flushed :: IO () -> IO ()
|
|
|
|
flushed a = a >> hFlush stdout
|