src/Darcs/Utils.lhs

   1 % Various utility functions that do not belong anywhere else.
   2
   3 \begin{code}
   4 {-# OPTIONS_GHC -cpp -fffi #-}
   5 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
   6
   7 module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand,
   8                      clarify_errors, prettyException,
   9                     putStrLnError, putDocLnError,
  10                     withCurrentDirectory,
  11                     withUMask, askUser, stripCr,
  12                     showHexLen, add_to_error_loc,
  13                     maybeGetEnv, firstNotBlank, firstJustM, firstJustIO,
  14                     isUnsupportedOperationError, isHardwareFaultError,
  15                     get_viewer, edit_file, promptYorn, promptCharFancy, without_buffering,
  16                     formatPath ) where
  17
  18 import Prelude hiding ( catch )
  19 import Control.Exception ( bracket, bracket_, catch, Exception(IOException), throwIO, try )
  20 import Control.Concurrent ( newEmptyMVar, takeMVar, putMVar, forkIO )
  21 #if !defined(WIN32) ||  __GLASGOW_HASKELL__>=609
  22 import Control.Concurrent ( threadWaitRead )
  23 #endif
  24 import GHC.IOBase ( IOException(ioe_location),
  25                     IOErrorType(UnsupportedOperation, HardwareFault) )
  26 import System.IO.Error ( isUserError, ioeGetErrorType, ioeGetErrorString )
  27
  28 import Darcs.SignalHandler ( catchNonSignal )
  29 import Numeric ( showHex )
  30 import System.Exit ( ExitCode(..) )
  31 import System.Environment ( getEnv )
  32 import System.IO ( hFlush, hPutStrLn, stderr, stdout, stdin,
  33                    BufferMode ( NoBuffering ),
  34                    hLookAhead, hReady, hSetBuffering, hGetBuffering, hIsTerminalDevice )
  35 import Data.Char ( toUpper )
  36 import Darcs.RepoPath ( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath )
  37 import Data.Maybe ( listToMaybe, isJust )
  38 import Data.List ( group, sort )
  39 import Control.Monad ( when )
  40 import Exec ( exec_interactive )
  41 import Printer ( Doc, hPutDocLn )
  42 import Foreign.C.String ( CString, withCString )
  43 import Foreign.C.Error ( throwErrno )
  44 import Foreign.C.Types ( CInt )
  45
  46 import Darcs.Progress ( withoutProgress )
  47
  48 #ifdef HAVE_HASKELINE
  49 import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine )
  50 #endif
  51
  52 #ifdef WIN32
  53 import System.Posix.Internals ( getEcho, setCooked, setEcho )
  54 #endif
  55
  56 showHexLen :: (Integral a) => Int -> a -> String
  57 showHexLen n x = let s = showHex x ""
  58                  in replicate (n - length s) ' ' ++ s
  59
  60 add_to_error_loc :: Exception -> String -> Exception
  61 add_to_error_loc (IOException ioe) s
  62     = IOException $ ioe { ioe_location = s ++ ": " ++ ioe_location ioe }
  63 add_to_error_loc e _ = e
  64
  65 isUnsupportedOperationError :: IOError -> Bool
  66 isUnsupportedOperationError = isUnsupportedOperationErrorType . ioeGetErrorType
  67
  68 isUnsupportedOperationErrorType :: IOErrorType -> Bool
  69 isUnsupportedOperationErrorType UnsupportedOperation = True
  70 isUnsupportedOperationErrorType _ = False
  71
  72 isHardwareFaultError :: IOError -> Bool
  73 isHardwareFaultError = isHardwareFaultErrorType . ioeGetErrorType
  74
  75 isHardwareFaultErrorType :: IOErrorType -> Bool
  76 isHardwareFaultErrorType HardwareFault = True
  77 isHardwareFaultErrorType _ = False
  78
  79 catchall :: IO a -> IO a -> IO a
  80 a `catchall` b = a `catchNonSignal` (\_ -> b)
  81
  82 maybeGetEnv :: String -> IO (Maybe String)
  83 maybeGetEnv s = (getEnv s >>= return.Just) `catchall` return Nothing -- err can only be isDoesNotExist
  84
  85
  86 -- |The firstJustM returns the first Just entry in a list of monadic operations.  This is close to
  87 --  `listToMaybe `fmap` sequence`, but the sequence operator evaluates all monadic members of the
  88 --  list before passing it along (i.e. sequence is strict).  The firstJustM is lazy in that list
  89 --  member monads are only evaluated up to the point where the first Just entry is obtained.
  90 firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a)
  91 firstJustM [] = return Nothing
  92 firstJustM (e:es) = e >>= (\v -> if isJust v then return v else firstJustM es)
  93
  94 -- |The firstJustIO is a slight modification to firstJustM: the
  95 --  entries in the list must be IO monad operations and the
  96 --  firstJustIO will silently turn any monad call that throws an
  97 --  exception into Nothing, basically causing it to be ignored.
  98 firstJustIO :: [IO (Maybe a)] -> IO (Maybe a)
  99 firstJustIO = firstJustM . map (\o -> o `catchall` return Nothing)
 100
 101
 102 clarify_errors :: IO a -> String -> IO a
 103 clarify_errors a e = a `catch` (\x -> fail $ unlines [prettyException x,e])
 104
 105 prettyException :: Control.Exception.Exception -> String
 106 prettyException (IOException e) | isUserError e = ioeGetErrorString e
 107 prettyException e = show e
 108
 109 ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode
 110 a `ortryrunning` b = do ret <- try a
 111                         case ret of
 112                           (Right ExitSuccess) -> return ExitSuccess
 113                           _ -> b
 114
 115 putStrLnError :: String -> IO ()
 116 putStrLnError = hPutStrLn stderr
 117
 118 putDocLnError :: Doc -> IO ()
 119 putDocLnError = hPutDocLn stderr
 120
 121 withCurrentDirectory :: FilePathLike p => p -> IO a -> IO a
 122 withCurrentDirectory name m =
 123     bracket
 124         (do cwd <- getCurrentDirectory
 125             when (toFilePath name /= "") (setCurrentDirectory name)
 126             return cwd)
 127         (\oldwd -> setCurrentDirectory oldwd `catchall` return ())
 128         (const m)
 129
 130 foreign import ccall unsafe "umask.h set_umask" set_umask
 131     :: CString -> IO CInt
 132 foreign import ccall unsafe "umask.h reset_umask" reset_umask
 133     :: CInt -> IO CInt
 134
 135 withUMask :: String -> IO a -> IO a
 136 withUMask umask job =
 137     do rc <-withCString umask set_umask
 138        when (rc < 0) (throwErrno "Couldn't set umask")
 139        bracket_
 140            (return ())
 141            (reset_umask rc)
 142            job
 143
 144 -- withThread is used to allow ctrl-C to work even while we're waiting for
 145 -- user input.  The job is run in a separate thread, and any exceptions it
 146 -- produces are re-thrown in the parent thread.
 147 withThread :: IO a -> IO a
 148 withThread j = do m <- newEmptyMVar
 149                   forkIO (runJob m)
 150                   takeMVar m >>= either throwIO return
 151     where runJob m = (j >>= putMVar m . Right) `catch` (putMVar m . Left)
 152
 153 askUser :: String -> IO String
 154 #ifdef HAVE_HASKELINE
 155 askUser prompt = withoutProgress $ runInputT defaultSettings (getInputLine prompt)
 156                         >>= maybe (error "askUser: unexpected end of input") return
 157
 158 #else
 159 askUser prompt = withThread $ withoutProgress $ do putStr prompt
 160                                                    hFlush stdout
 161                                                    waitForStdin
 162 #ifndef WIN32
 163                                                    getLine
 164 #else
 165                                                    stripCr `fmap` getLine
 166 #endif
 167 #endif
 168
 169 waitForStdin :: IO ()
 170 #ifdef WIN32
 171 #if __GLASGOW_HASKELL__ >= 609
 172 waitForStdin = threadWaitRead 0
 173 #else
 174 waitForStdin = return ()  -- threadWaitRead didn't work prior to 6.9
 175 #endif
 176 #else
 177 waitForStdin = threadWaitRead 0
 178 #endif
 179
 180 stripCr :: String -> String
 181 stripCr ""     = ""
 182 stripCr "\r"   = ""
 183 stripCr (c:cs) = c : stripCr cs
 184
 185 -- |Returns Just l where l is first non-blank string in input array; Nothing if no non-blank entries
 186 firstNotBlank :: [String] -> Maybe String
 187 firstNotBlank = listToMaybe . filter (not . null)
 188
 189
 190 -- Format a path for screen output,
 191 -- so that the user sees where the path begins and ends.
 192 -- Could (should?) also warn about unprintable characters here.
 193 formatPath :: String -> String
 194 formatPath path = "\"" ++ quote path ++ "\""
 195     where quote "" = ""
 196           quote (c:cs) = if c=='\\' || c=='"'
 197                          then '\\':c:quote cs
 198                          else c:quote cs
 199
 200 breakCommand :: String -> (String, [String])
 201 breakCommand s = case words s of
 202                    (arg0:args) -> (arg0,args)
 203                    [] -> (s,[])
 204
 205 nubsort :: Ord a => [a] -> [a]
 206 nubsort = map head . group . sort
 207
 208 \end{code}
 209
 210 \begin{code}
 211 edit_file :: FilePathLike p => p -> IO ExitCode
 212 edit_file ff = do
 213   let f = toFilePath ff
 214   ed <- get_editor
 215   exec_interactive ed f
 216              `ortryrunning` exec_interactive "emacs" f
 217              `ortryrunning` exec_interactive "emacs -nw" f
 218              `ortryrunning` exec_interactive "nano" f
 219 #ifdef WIN32
 220              `ortryrunning` exec_interactive "edit" f
 221 #endif
 222 get_editor :: IO String
 223 get_editor = getEnv "DARCS_EDITOR" `catchall`
 224              getEnv "DARCSEDITOR" `catchall`
 225              getEnv "VISUAL" `catchall`
 226              getEnv "EDITOR" `catchall` return "vi"
 227 \end{code}
 228
 229 \begin{code}
 230 get_viewer :: IO String
 231 get_viewer = getEnv "DARCS_PAGER" `catchall`
 232              getEnv "PAGER" `catchall` return "less"
 233 \end{code}
 234
 235 \begin{code}
 236 promptYorn :: [Char] -> IO Char
 237 promptYorn p = promptCharFancy p "yn" Nothing []
 238
 239 promptCharFancy :: String -> [Char] -> Maybe Char -> [Char] -> IO Char
 240 promptCharFancy p chs md help_chs =
 241  do a <- withThread $ without_buffering $
 242            do putStr $ p ++ " ["++ setDefault chs ++"]" ++ helpStr
 243               hFlush stdout
 244               waitForStdin
 245               c <- getChar
 246 #ifdef WIN32
 247               -- We need to simulate echo
 248               e <- get_raw_mode
 249               when e $ putChar c
 250 #endif
 251               return c
 252     when (a /= '\n') $ putStr "\n"
 253     case () of
 254      _ | a `elem` chs                   -> return a
 255        | a == ' ' -> case md of Nothing -> tryAgain
 256                                 Just d  -> return d
 257        | a `elem` help_chs              -> return a
 258        | otherwise                      -> tryAgain
 259  where
 260  helpStr = case help_chs of
 261            []    -> ""
 262            (h:_) -> ", or " ++ (h:" for help: ")
 263  tryAgain = do putStrLn "Invalid response, try again!"
 264                promptCharFancy p chs md help_chs
 265  setDefault s = case md of Nothing -> s
 266                            Just d  -> map (setUpper d) s
 267  setUpper d c = if d == c then toUpper c else c
 268
 269 without_buffering :: IO a -> IO a
 270 without_buffering job = withoutProgress $ do
 271     bracket nobuf rebuf $ \_ -> job
 272     where nobuf = do is_term <- hIsTerminalDevice stdin
 273                      bi <- hGetBuffering stdin
 274                      raw <- get_raw_mode
 275                      when is_term $ do hSetBuffering stdin NoBuffering `catch` \_ -> return ()
 276                                        set_raw_mode True
 277                      return (bi,raw)
 278           rebuf (bi,raw) = do is_term <- hIsTerminalDevice stdin
 279 #if SYS == windows
 280                               buffers <- hGetBuffering stdin
 281                               hSetBuffering stdin NoBuffering `catch` \_ -> return ()
 282                               drop_returns
 283                               hSetBuffering stdin buffers `catch` \_ -> return ()
 284 #else
 285                               drop_returns
 286 #endif
 287                               when is_term $ do hSetBuffering stdin bi `catch` \_ -> return ()
 288                                                 set_raw_mode raw
 289           drop_returns = do is_ready <- hReady stdin
 290                             when is_ready $
 291                               do waitForStdin
 292                                  c <- hLookAhead stdin `catch` \_ -> return ' '
 293                                  when (c == '\n') $
 294                                    do getChar
 295                                       drop_returns
 296 \end{code}
 297
 298 Code which was in the module RawMode before. Moved here to break cyclic imports
 299
 300 \begin{code}
 301 #ifdef WIN32
 302
 303 get_raw_mode :: IO Bool
 304 get_raw_mode = not `fmap` getEcho 0
 305   `catchall` return False -- getEcho sometimes fails when called from scripts
 306
 307 set_raw_mode :: Bool -> IO ()
 308 set_raw_mode raw = (setCooked 0 normal >> setEcho 0 normal)
 309    `catchall` return () -- setCooked sometimes fails when called from scripts
 310  where normal = not raw
 311
 312 #else
 313
 314 get_raw_mode :: IO Bool
 315 get_raw_mode = return False
 316
 317 set_raw_mode :: Bool -> IO ()
 318 set_raw_mode _ = return ()
 319
 320 #endif
 321 \end{code}