git-annex/Messages.hs

142 lines
3.2 KiB
Haskell
Raw Normal View History

2010-11-08 19:15:21 +00:00
{- git-annex output messages
-
2011-11-15 04:30:00 +00:00
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
2010-11-08 19:15:21 +00:00
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Messages (
showStart,
showNote,
showAction,
showProgress,
showSideAction,
showOutput,
showLongNote,
showEndOk,
showEndFail,
showEndResult,
showErr,
warning,
indent,
maybeShowJSON,
2011-12-23 02:03:18 +00:00
showFullJSON,
2011-11-15 04:30:00 +00:00
showCustom,
showHeader,
showRaw,
setupConsole
) where
2010-11-08 19:15:21 +00:00
import Text.JSON
2010-11-08 19:15:21 +00:00
import Common
2010-11-08 19:15:21 +00:00
import Types
import qualified Annex
import qualified Messages.JSON as JSON
2010-11-08 19:15:21 +00:00
showStart :: String -> String -> Annex ()
showStart command file = handle (JSON.start command $ Just file) $
2011-10-11 18:43:45 +00:00
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 ++ ") "
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 "."
showSideAction :: String -> Annex ()
2011-10-11 18:43:45 +00:00
showSideAction s = handle q $
putStrLn $ "(" ++ s ++ "...)"
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 ()
showEndOk = showEndResult True
2010-11-08 19:15:21 +00:00
showEndFail :: Annex ()
showEndFail = showEndResult False
2010-11-08 19:15:21 +00:00
2011-05-15 16:25:58 +00:00
showEndResult :: Bool -> Annex ()
showEndResult ok = handle (JSON.end ok) $ putStrLn msg
where
msg
| ok = "ok"
| otherwise = "failed"
2011-05-15 16:25:58 +00:00
2010-11-08 19:15:21 +00:00
showErr :: (Show a) => a -> Annex ()
showErr e = warning' $ "git-annex: " ++ show e
2010-11-08 19:15:21 +00:00
warning :: String -> Annex ()
warning = warning' . indent
warning' :: String -> Annex ()
warning' w = do
handle q $ putStr "\n"
liftIO $ do
hFlush stdout
hPutStrLn stderr w
2011-01-27 00:30:07 +00:00
indent :: String -> String
indent = join "\n" . map (\l -> " " ++ l) . lines
2011-12-23 02:03:18 +00:00
{- Shows a JSON fragment only when in json mode. -}
2011-11-15 04:30:00 +00:00
maybeShowJSON :: JSON a => [(String, a)] -> Annex ()
maybeShowJSON v = handle (JSON.add v) q
2011-12-23 02:03:18 +00:00
{- Shows a complete JSON value, only when in json mode. -}
showFullJSON :: JSON a => [(String, a)] -> Annex Bool
showFullJSON v = Annex.getState Annex.output >>= liftIO . go
where
go Annex.JSONOutput = JSON.complete v >> return True
go _ = return False
2011-11-15 04:30:00 +00:00
{- Performs an action that outputs nonstandard/customized output, and
- in JSON mode wraps its output in JSON.start and JSON.end, so it's
- a complete JSON document.
- This is only needed when showStart and showEndOk is not used. -}
showCustom :: String -> Annex Bool -> Annex ()
showCustom command a = do
handle (JSON.start command Nothing) q
r <- a
handle (JSON.end r) q
showHeader :: String -> Annex ()
showHeader h = handle q $
flushed $ putStr $ h ++ ": "
2011-11-15 04:30:00 +00:00
showRaw :: String -> Annex ()
showRaw s = handle q $ putStrLn s
support all filename encodings with ghc 7.4 Under ghc 7.4, this seems to be able to handle all filename encodings again. Including filename encodings that do not match the LANG setting. I think this will not work with earlier versions of ghc, it uses some ghc internals. Turns out that ghc 7.4 has a special filesystem encoding that it uses when reading/writing filenames (as FilePaths). This encoding is documented to allow "arbitrary undecodable bytes to be round-tripped through it". So, to get FilePaths from eg, git ls-files, set the Handle that is reading from git to use this encoding. Then things basically just work. However, I have not found a way to make Text read using this encoding. Text really does assume unicode. So I had to switch back to using String when reading/writing data to git. Which is a pity, because it's some percent slower, but at least it works. Note that stdout and stderr also have to be set to this encoding, or printing out filenames that contain undecodable bytes causes a crash. IMHO this is a misfeature in ghc, that the user can pass you a filename, which you can readFile, etc, but that default, putStr of filename may cause a crash! Git.CheckAttr gave me special trouble, because the filenames I got back from git, after feeding them in, had further encoding breakage. Rather than try to deal with that, I just zip up the input filenames with the attributes. Which must be returned in the same order queried for this to work. Also of note is an apparent GHC bug I worked around in Git.CheckAttr. It used to forkProcess and feed git from the child process. Unfortunatly, after this forkProcess, accessing the `files` variable from the parent returns []. Not the value that was passed into the function. This screams of a bad bug, that's clobbering a variable, but for now I just avoid forkProcess there to work around it. That forkProcess was itself only added because of a ghc bug, #624389. I've confirmed that the test case for that bug doesn't reproduce it with ghc 7.4. So that's ok, except for the new ghc bug I have not isolated and reported. Why does this simple bit of code magnet the ghc bugs? :) Also, the symlink touching code is currently broken, when used on utf-8 filenames in a non-utf-8 locale, or probably on any filename containing undecodable bytes, and I temporarily commented it out.
2012-02-03 19:12:41 +00:00
{- This avoids ghc's output layer crashing on invalid encoded characters in
2012-02-04 20:37:55 +00:00
- filenames when printing them out.
2012-02-03 05:38:23 +00:00
-}
setupConsole :: IO ()
support all filename encodings with ghc 7.4 Under ghc 7.4, this seems to be able to handle all filename encodings again. Including filename encodings that do not match the LANG setting. I think this will not work with earlier versions of ghc, it uses some ghc internals. Turns out that ghc 7.4 has a special filesystem encoding that it uses when reading/writing filenames (as FilePaths). This encoding is documented to allow "arbitrary undecodable bytes to be round-tripped through it". So, to get FilePaths from eg, git ls-files, set the Handle that is reading from git to use this encoding. Then things basically just work. However, I have not found a way to make Text read using this encoding. Text really does assume unicode. So I had to switch back to using String when reading/writing data to git. Which is a pity, because it's some percent slower, but at least it works. Note that stdout and stderr also have to be set to this encoding, or printing out filenames that contain undecodable bytes causes a crash. IMHO this is a misfeature in ghc, that the user can pass you a filename, which you can readFile, etc, but that default, putStr of filename may cause a crash! Git.CheckAttr gave me special trouble, because the filenames I got back from git, after feeding them in, had further encoding breakage. Rather than try to deal with that, I just zip up the input filenames with the attributes. Which must be returned in the same order queried for this to work. Also of note is an apparent GHC bug I worked around in Git.CheckAttr. It used to forkProcess and feed git from the child process. Unfortunatly, after this forkProcess, accessing the `files` variable from the parent returns []. Not the value that was passed into the function. This screams of a bad bug, that's clobbering a variable, but for now I just avoid forkProcess there to work around it. That forkProcess was itself only added because of a ghc bug, #624389. I've confirmed that the test case for that bug doesn't reproduce it with ghc 7.4. So that's ok, except for the new ghc bug I have not isolated and reported. Why does this simple bit of code magnet the ghc bugs? :) Also, the symlink touching code is currently broken, when used on utf-8 filenames in a non-utf-8 locale, or probably on any filename containing undecodable bytes, and I temporarily commented it out.
2012-02-03 19:12:41 +00:00
setupConsole = do
fileEncoding stdout
fileEncoding stderr
handle :: IO () -> IO () -> Annex ()
handle json normal = Annex.getState Annex.output >>= go
where
go Annex.NormalOutput = liftIO normal
go Annex.QuietOutput = q
2012-02-16 04:41:30 +00:00
go Annex.JSONOutput = liftIO $ flushed json
q :: Monad m => m ()
q = return ()
2011-10-11 18:43:45 +00:00
flushed :: IO () -> IO ()
flushed a = a >> hFlush stdout