module Hbro.Util where
import Hbro.Types
import Control.Concurrent
import Control.Exception
import Control.Monad hiding(mapM_)
import Control.Monad.Error hiding(mapM_)
import Control.Monad.Reader hiding(mapM_)
import Control.Monad.Trans.Control
import Data.Foldable
import Data.Functor
import Data.IORef
import Data.List
import Graphics.Rendering.Pango.Enums
import Graphics.UI.Gtk.Display.Label
import Graphics.UI.Gtk.Gdk.EventM
import Graphics.UI.Gtk.General.General
import Graphics.UI.Gtk.WebKit.Download as W
import Graphics.UI.Gtk.WebKit.NetworkRequest as W
import Network.URI (URI)
import qualified Network.URI as N
import Prelude hiding(log, mapM_)
import System.Console.CmdArgs
import System.FilePath
import qualified System.Info as Sys
import System.IO.Error hiding(try)
import System.Posix.Process
import System.Posix.Types
import System.Process
io :: MonadIO m => IO a -> m a
io = liftIO
fork :: (MonadIO m, MonadBaseControl IO m) => m () -> m (MVar ())
fork f = do
mvar <- io newEmptyMVar
void . liftBaseWith $ \runInIO -> forkIO $ finally (void $ runInIO f) (putMVar mvar ())
return mvar
(>/>) :: (MonadIO m) => IO FilePath -> FilePath -> m FilePath
(>/>) a b = io $ (</> b) <$> a
logNormal, logVerbose :: (MonadIO m) => String -> m ()
logNormal = io . whenNormal . putStrLn
logVerbose = io . whenLoud . putStrLn
spawn :: MonadIO m => String -> [String] -> m ()
spawn command options = io . void $ createProcess (proc command options) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, close_fds = True }
getAllProcessIDs :: MonadIO m => m [ProcessID]
getAllProcessIDs = do
(_, pids, _) <- io $ readProcessWithExitCode "pidof" ["hbro"] []
(_, pids', _) <- io $ readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] []
myPid <- io $ getProcessID
return $ delete myPid . map (read :: String -> ProcessID) . nub . words $ pids ++ " " ++ pids'
labelSetMarkupTemporary :: Label -> String -> Int -> IO ()
labelSetMarkupTemporary label text delay = do
labelSetMarkup label text
timeoutAdd (clear >> return False) delay >> return ()
where
clear = labelSetMarkup label ""
errorHandler :: FilePath -> IOError -> IO ()
errorHandler file e = do
when (isAlreadyInUseError e) $ (whenNormal . putStrLn) ("ERROR: file <" ++ file ++ "> is already opened and cannot be reopened.")
when (isDoesNotExistError e) $ (whenNormal . putStrLn) ("ERROR: file <" ++ file ++ "> doesn't exist.")
when (isPermissionError e) $ (whenNormal . putStrLn) ("ERROR: user doesn't have permission to open file <" ++ file ++ ">.")
parseURIReference :: (MonadError HError m) => String -> m URI
parseURIReference uri = maybe (throwError $ InvalidURI uri) return $ N.parseURIReference uri
parseURI :: (MonadError HError m) => String -> m URI
parseURI uri = maybe (throwError $ InvalidURI uri) return $ N.parseURI uri
networkRequestGetUri :: (MonadIO m, MonadError HError m) => NetworkRequest -> m URI
networkRequestGetUri r = parseURIReference =<< maybe (throwError $ EmptyRequestURI r) return =<< io (W.networkRequestGetUri r)
downloadGetUri :: (MonadIO m, MonadError HError m) => W.Download -> m URI
downloadGetUri d = parseURI =<< maybe (throwError $ EmptyDownloadURI d) return =<< io (W.downloadGetUri d)
downloadGetSuggestedFilename :: (MonadIO m, MonadError HError m) => W.Download -> m String
downloadGetSuggestedFilename d = maybe (throwError $ EmptySuggestedFileName d) return =<< io (W.downloadGetSuggestedFilename d)
isCaseSensitive :: CaseSensitivity -> Bool
isCaseSensitive CaseSensitive = True
isCaseSensitive _ = False
isForward :: Direction -> Bool
isForward Forward = True
isForward _ = False
isWrapped :: Wrap -> Bool
isWrapped Wrap = True
isWrapped _ = False
allItalic, allBold :: PangoAttribute
allItalic = AttrStyle {paStart = 0, paEnd = 1, paStyle = StyleItalic}
allBold = AttrWeight {paStart = 0, paEnd = 1, paWeight = WeightBold}
notify :: (Functor m, MonadIO m, MonadReader r m, HasNotificationBar r, HasHooks r, MonadError HError m) => Int -> String -> m ()
notify duration text = do
label <- _label <$> asks _notificationbar
handler <- asks _notificationTimer
io $ labelSetAttributes label [AttrForeground {paStart = 0, paEnd = 1, paColor = Color 32767 32767 32767}]
io $ labelSetMarkup label text
io $ mapM_ timeoutRemove =<< readIORef handler
newID <- io $ timeoutAdd (labelSetMarkup label "" >> return False) duration
io $ writeIORef handler $ Just newID
stringify :: Modifier -> String
stringify Control = "C-"
stringify Alt = "M-"
stringify _ = []