himerge-0.20: src/Util.hs
{-
Functions for basic and common operations.
Copyright (C) 2007, 2008 Luis Francisco Araujo <araujo@gentoo.org>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
-}
module Util
where
import Data.Char
import System.Directory
import Graphics.UI.Gtk
import System.Exit
import System.IO
import System.Time
import System.Process
import Control.Concurrent
import qualified Control.Exception as E
import System.Glib.Types
import System.Glib.Properties
(objectSetPropertyBool)
import Data.List (sort)
data ProcessType = Emerge | EmergeSync | Eix
deriving (Show, Eq)
data TabButtons = StopButton | CloseButton | StopCloseButton
hname, hversion :: String
hname = "Himerge"
hversion = "0.20"
hdoc :: FilePath
hdoc = "/usr/share/doc/himerge-" ++ hversion ++ "/himerge_doc.html"
envbin :: FilePath
envbin = "/bin/env"
revdeprebuild, portageroot, eixpath, updateeix :: FilePath
revdeprebuild = envbin ++ " revdep-rebuild"
updateeix = envbin ++ " update-eix"
eixpath = envbin ++ " eix -n -v -x "
portageroot = "/usr/portage"
makeconfpath, etcpackage :: FilePath
makeconfpath = "/etc/make.conf"
etcpackage = "/etc/portage/"
packagekeywords, packagemask, packageunmask, packageuse :: FilePath
packagekeywords = etcpackage ++ "package.keywords"
packagemask = etcpackage ++ "package.mask"
packageunmask = etcpackage ++ "package.unmask"
packageuse = etcpackage ++ "package.use"
iconpath :: FilePath
iconpath = "/usr/share/himerge/icons/"
categoryicon, packageicon, ebuildicon :: FilePath
searchicon, windowlogo, tabstopicon :: FilePath
packageicon = iconpath ++ "package.png"
ebuildicon = iconpath ++ "ebuild.png"
categoryicon = iconpath ++ "category.png"
windowlogo = iconpath ++ "himerge-32.png"
searchicon = iconpath ++ "search.png"
tabstopicon = iconpath ++ "process-stop.png"
imageColumn, textColumn :: Int
imageColumn = 0
textColumn = 1
removeddirs :: [FilePath]
{-| List of directories to be omitted on the browser views. -}
removeddirs = ["distfiles", "eclass", "profiles", "licenses"
, "packages", "metadata", "scripts", "local"]
setQueueColor :: String -> String -> String
setQueueColor color msg = "<span foreground=\"" ++ color ++ "\"><b>" ++ msg ++ "</b></span>"
splitStr :: Char -> String -> [String]
splitStr c = words . map (\ n -> if c == n then ' ' else n)
joinStr :: Char -> [String] -> String
joinStr c xs = let l = last xs in (concat $ map (\ x -> x ++ [c]) $ init xs) ++ l
findSubstring :: String -> String -> Bool
findSubstring a b = f a b a
where f [] _ _ = True
f _ [] _ = False
f (x:xs) (y:ys) cs | x == y = f xs ys cs | otherwise = f cs ys cs
getDirectory :: FilePath -> IO [FilePath]
getDirectory xs =
(mapM (return . (xs ++)) . removeOddDirs
=<< getDirectoryContents xs) >>=
mapM (\ d -> do
bool <- doesDirectoryExist d
if bool == True then return d else return []) >>=
return . sort . map getDirName . filter (/= [])
getVersion :: FilePath -> IO [String]
getVersion f = getDirectoryContents f >>=
return . sort . map removeSuffix
. filter isEbuild . removeOddDirs
removeOddDirs :: [String] -> [String]
removeOddDirs = filter (not . flip any ".:_\\'" . (==) . head)
filterDirs :: [String] -> [String] -> [String]
filterDirs = filter . flip (.) ((.) (&&) . (/=))
. (flip $ flip foldr True)
getDirName :: String -> String
getDirName = reverse . takeWhile (/= '/') . reverse
isEbuild :: String -> Bool
isEbuild = ((== "ebuild") . reverse . takeWhile (/= '.') . reverse)
removeSuffix :: String -> String
removeSuffix = init . reverse . dropWhile (/= '.') . reverse
parseLabel :: String -> String
parseLabel = takeWhile (/= ' ') . dropWhile (not . isAlpha)
updateBar :: ProgressBar -> IO a
updateBar pb =
progressBarPulse pb >> threadDelay 90000 >>
updateBar pb
updateStatBar :: Statusbar -> String -> IO ()
updateStatBar statbar str =
statusbarGetContextId statbar "message" >>=
flip (statusbarPush statbar) str >>
return ()
refreshStatBar :: Statusbar -> String -> IO ()
refreshStatBar statbar statmsg =
updateStatBar statbar statmsg >> threadDelay 9000000 >>
refreshStatBar statbar statmsg
onExit :: ProcessHandle -> (ExitCode -> IO ()) -> IO ()
onExit ph func =
do
threadDelay 3000
exitcode <- getProcessExitCode ph
`E.catch` (\ _ -> getProcessExitCode ph)
case exitcode of
Nothing -> onExit ph func
Just status -> func status
makeFrame :: String -> Float -> Float -> IO Frame
makeFrame label xalign yalign =
do
frame <- frameNew
frameSetLabel frame label
frameSetLabelAlign frame xalign yalign
return frame
makeTextBuffer, makeView :: Bool -> IO (ScrolledWindow, TextView)
makeTextBuffer bool =
do
scroll <- scrolledWindowNew Nothing Nothing
texttag <- textTagNew $ Just "emerge"
set texttag [ textTagEditable := bool ]
texttable <- textTagTableNew
textTagTableAdd texttable texttag
textb <- textBufferNew $ Just texttable
startiter <- textBufferGetStartIter textb
-- Create a mark to preserve position across buffer changes.
textBufferCreateMark textb (Just "emerge") startiter False
textv <- textViewNewWithBuffer textb
textViewSetCursorVisible textv bool
containerAdd scroll textv
return (scroll, textv)
makeView = makeTextBuffer
showProcessBuffer, showEmergeBuffer :: ProcessType -> Handle -> TextView
-> TextBuffer -> IO ()
showProcessBuffer ptype handle textv textb =
do
threadDelay 1
close <- hIsClosed handle
eof <- hIsEOF handle
if close || eof
then return ()
else hGetLine handle >>= return . formatProcess ptype >>=
updateEmergeBuffer textv textb >>
showProcessBuffer ptype handle textv textb
showEmergeBuffer = showProcessBuffer
formatProcess :: ProcessType -> String -> String
{- | Formatting options depending on process type. -}
formatProcess ptype xs =
case ptype of
Eix -> formatEix $ cleanOutput xs
EmergeSync -> formatSync $ cleanOutput xs
_ -> cleanOutput xs
formatEix, formatSync :: String -> String
{- | Avoid those ugly percents characters from the eix updating. -}
formatEix xs = if (take 3 $ reverse xs) == "%00"
then "==> Reading Completed <=="
else xs
formatSync = formatEix
updateBuffer , updateEmergeBuffer :: TextView -> TextBuffer -> String -> IO ()
updateBuffer textv textb xs =
do
(Just mark) <- textBufferGetMark textb "emerge"
insertiter <- textBufferGetIterAtMark textb mark
textBufferInsert textb insertiter (xs ++ "\n")
textViewScrollToIter textv insertiter 0.0 Nothing
return ()
updateEmergeBuffer = updateBuffer
updateTextBuffer :: (TextViewClass t) => t -> String -> IO ()
{- | Update text view. -}
updateTextBuffer = (. flip textBufferSetText) . (>>=) . textViewGetBuffer
writeLog :: TextView -> String -> IO ()
writeLog tv str =
do
time <- getTime
let hstr = "# " ++ time ++ "\n" ++ str ++ "\n"
textViewGetBuffer tv >>= flip (updateBuffer tv) hstr
getTime :: IO String
getTime = getClockTime >>= toCalendarTime >>= return . calendarTimeToString
commandView :: (String, String, String, String)
-> ProcessType -> Notebook -> TextView
-> Statusbar -> ProgressBar -> IO ()
{- | Run the command and update a specific text view buffer. -}
commandView (command, statmsg, successmsg, errormsg)
ptype panel logview statbar progbar =
do
(viewscroll, view) <- makeView False
-- Build the panel page with the proper buttons for the tab.
(tooltips, (Just stopbutton), (Just closebutton))
<- buildPanelTab viewscroll panel statmsg StopCloseButton
widgetShowAll viewscroll
-- Jump to the page processing the operation.
notebookSetCurrentPage panel (-1)
progressBarSetFraction progbar 0.0
-- Write logs and show status.
writeLog logview statmsg
statid <- forkIO $ refreshStatBar statbar (statmsg ++ " ...")
-- Get the text buffer from the text view.
ebuf <- textViewGetBuffer view
textBufferSetText ebuf []
-- Start command process.
(_,out,err,ph) <- runInteractiveCommand command
barthread <- forkIO $ updateBar progbar
-- Show stdout.
forkIO $ showProcessBuffer ptype out view ebuf
-- Show stderr.
forkIO $ showProcessBuffer ptype err view ebuf
-- Connect signal to the stop-process and close-tab buttons.
stopbutton `onClicked`
(do
exitcode <- getProcessExitCode ph
case exitcode of
Nothing -> popSelectWindow ("Stop " ++ command) (terminateProcess ph)
Just _ -> popInfoWindow "This process is already stopped.")
closebutton `onClicked`
(do
exitcode <- getProcessExitCode ph
case exitcode of
Nothing -> popWarningWindow "The process is still running.\n\
\Stop this process first and then close the tab."
Just _ -> do
(Just text) <- notebookGetMenuLabelText panel viewscroll
popSelectWindow ("Do you really want to close [" ++ text ++ "]?")
(tooltipsEnable tooltips >> closeTab panel viewscroll))
-- Test for process result.
forkIO $ onExit ph ((.) ((>>) (killThread statid)) (handleExitCode barthread))
return ()
where
handleExitCode thread exitcode =
killThread thread >>
case exitcode of
ExitSuccess -> writeLog logview successmsg >>
updateStatBar statbar successmsg >>
progressBarSetFraction progbar 1.0 >>
if ptype == EmergeSync
then updateEix panel logview statbar progbar
else return ()
ExitFailure 115 -> writeLog logview (statmsg ++ " : stopped") >>
updateStatBar statbar (statmsg ++ " : stopped") >>
progressBarSetFraction progbar 0.0
_ -> popErrorWindow errormsg >>
writeLog logview errormsg >>
updateStatBar statbar errormsg >>
progressBarSetFraction progbar 0.0
buildPanelTab :: WidgetClass w => w -> Notebook -> String -> TabButtons
-> IO (Tooltips, Maybe Button, Maybe Button)
buildPanelTab widget panel msg isbutton =
do
tablabel <- labelNew $ Just msg
menulabel <- labelNew $ Just msg
tooltips <- tooltipsNew
tabheader <- hBoxNew False 0
(isstop, isclose)
<- case isbutton of
StopButton -> stop tabheader tooltips >>= return . flip (,) Nothing . Just
CloseButton -> close tabheader tooltips >>= return . (,) Nothing . Just
StopCloseButton -> stop tabheader tooltips >>=
\ s -> close tabheader tooltips >>=
return . (,) (Just s) . Just
-- Pack the tab header.
boxPackStart tabheader tablabel PackNatural 0
notebookAppendPageMenu panel widget tabheader menulabel
widgetShowAll tabheader
return (tooltips, isstop, isclose)
where
stop paneltab tips = do
-- Stop button.
stopbutton <- buttonNew
stopicon <- imageNewFromFile tabstopicon
boxPackEnd paneltab stopbutton PackNatural 0
buttonSetRelief stopbutton ReliefNone
buttonSetImage stopbutton stopicon
tooltipsSetTip tips stopbutton "Stop process" []
return stopbutton
close paneltab tips = do
-- Close button.
closebutton <- buttonNew
closeicon <- imageNewFromStock stockClose 1
boxPackEnd paneltab closebutton PackNatural 0
buttonSetRelief closebutton ReliefNone
buttonSetImage closebutton closeicon
tooltipsSetTip tips closebutton "Close tab" []
return closebutton
updateEix :: Notebook -> TextView -> Statusbar -> ProgressBar -> IO ()
updateEix = commandView (updateeix, "Updating eix cache", "Eix cache successfully updated.",
"Error updating eix cache.") Eix
isWidget :: WidgetClass a => a -> String -> IO Bool
isWidget widget str =
do
name <- widgetGetName widget
if name == str
then return True
else return False
isCurrentPagePackagePanel :: Notebook -> (TreeView -> IO ()) -> IO ()
isCurrentPagePackagePanel panel func =
do
page <- notebookGetCurrentPage panel
(Just child) <- notebookGetNthPage panel page
b <- isWidget child "scrollview"
if b
then do
(Just totv) <- binGetChild (castToScrolledWindow child)
b' <- isWidget totv "treeview"
if b'
then func $ castToTreeView totv -- Apply the function to the treeview.
else popErrorWindow "This panel is not a proper list of packages."
else popErrorWindow "This panel is not a proper package view."
popWindow :: StockId -> String -> IO ()
popWindow stock xs =
do
dia <- dialogNew
diabox <- dialogGetUpper dia
hbox <- hBoxNew False 5
image <- imageNewFromStock stock (-1)
label <- labelNew $ Just xs
set dia [ windowTitle := "himerge"
, windowDefaultWidth := 400
, windowDefaultHeight := 90
, containerBorderWidth := 9 ]
boxPackStart hbox image PackNatural 5
boxPackStart hbox label PackNatural 5
boxPackStartDefaults diabox hbox
dialogAddButton dia stockOk ResponseOk
widgetShow label
widgetShow image
widgetShow hbox
dialogRun dia
widgetDestroy dia
return ()
popInfoWindow, popWarningWindow, popErrorWindow :: String -> IO ()
popErrorWindow = popWindow stockDialogError
popWarningWindow = popWindow stockDialogWarning
popInfoWindow = popWindow stockInfo
popSelectWindow :: String -> IO () -> IO ()
popSelectWindow xs f =
do
dia <- dialogNew
diabox <- dialogGetUpper dia
hbox <- hBoxNew False 5
image <- imageNewFromStock stockDialogQuestion (-1)
label <- labelNew (Just xs)
set dia [ windowTitle := "himerge"
, windowDefaultWidth := 400
, windowDefaultHeight := 90
, containerBorderWidth := 9 ]
boxPackStart hbox image PackNatural 5
boxPackStart hbox label PackNatural 5
boxPackStartDefaults diabox hbox
dialogAddButton dia stockCancel ResponseCancel
dialogAddButton dia stockOk ResponseOk
widgetShow label
widgetShow image
widgetShow hbox
dia `onResponse` (\ response ->
case response of
ResponseOk -> f
_ -> return ())
dialogRun dia
widgetDestroy dia
return ()
createQueueStore :: IO (TreeView, ScrolledWindow)
{- | Create the 'Queue' treeview. -}
createQueueStore =
do
scroll <- scrolledWindowNew Nothing Nothing
-- create the liststore.
store <- listStoreNew [TMstring, TMstring, TMobject, TMstring, TMstring]
-- create treeview.
tv <- treeViewNewWithModel store
treeViewSetHeadersVisible tv True
sel <- treeViewGetSelection tv
treeSelectionSetMode sel SelectionMultiple
-- cell renderer.
statcell <- cellRendererTextNew
actcell <- cellRendererTextNew
imagecell <- cellRendererPixbufNew
textcell <- cellRendererTextNew
tvcstat <- treeViewColumnNew
tvcact <- treeViewColumnNew
tvcpkg <- treeViewColumnNew
-- pack the column inside the view.
-- stat info.
treeViewColumnPackStart tvcstat statcell False
treeViewColumnAddAttributes tvcstat statcell [("markup", 0), ("background", 4)]
-- action info.
treeViewColumnPackStart tvcact actcell False
treeViewColumnAddAttribute tvcact actcell "markup" 1
-- image cell.
treeViewColumnPackStart tvcpkg imagecell False
treeViewColumnAddAttribute tvcpkg imagecell "pixbuf" 2
-- text cell.
treeViewColumnPackEnd tvcpkg textcell True
treeViewColumnAddAttribute tvcpkg textcell "text" 3
-- Columns title.
treeViewColumnSetTitle tvcstat "Status"
treeViewColumnSetTitle tvcact "Action"
treeViewColumnSetTitle tvcpkg "Packages"
treeViewAppendColumn tv tvcstat
treeViewAppendColumn tv tvcact
treeViewAppendColumn tv tvcpkg
-- Column to search.
treeViewSetSearchColumn tv 3
-- add treeview into the scroll container.
containerAdd scroll tv
-- Panel pop-up menu.
tv `onButtonRelease` queuePopupMenu tv
return (tv, scroll)
queuePopupMenu :: TreeView -> Event -> IO Bool
queuePopupMenu tv event@(Button { eventClick = ReleaseClick , eventButton = RightButton }) =
do
queuemenu <- menuNew
-- remove package from queue.
removequeue <- imageMenuItemNewWithLabel "remove selected packages"
removeicon <- imageNewFromFile (iconpath ++ "small-remove.png")
imageMenuItemSetImage removequeue removeicon
menuShellAppend queuemenu removequeue
removequeue `onActivateLeaf` removeElement tv
-- clear queue.
clearqueue <- imageMenuItemNewWithLabel "clear this package queue"
clearicon <- imageNewFromFile (iconpath ++ "small-clear.png")
imageMenuItemSetImage clearqueue clearicon
menuShellAppend queuemenu clearqueue
clearqueue `onActivateLeaf` clearQueue tv
widgetShowAll queuemenu
menuPopup queuemenu (Just (eventButton event, eventTime event))
return True
queuePopupMenu _ _ = return False
storeQueueObjects :: ListStore -> Pixbuf -> [(String, String)] -> IO ()
storeQueueObjects st pixbuf =
mapM_ (\ (s, p) -> do
i <- listStoreAppend st
-- Set what color to use for the action letter.
let actcolor = case s of
"NS" -> "orange"
"N" -> "green"
"U" -> "purple"
"D" -> "red"
"R" -> "yellow"
"F" -> "brown"
"f" -> "brown"
"A" -> "blue"
_ -> "lightblue"
listStoreSetValue st i 0 (GVstring (Just $ setQueueColor "blue" "Queued"))
listStoreSetValue st i 1 (GVstring (Just $ setQueueColor actcolor ("[ "++s++" ]")))
listStoreSetValue st i 2 (GVobject (toGObject pixbuf))
listStoreSetValue st i 3 (GVstring (Just p))
listStoreSetValue st i 4 (GVstring (Just "lightblue")))
createStore :: String -> SelectionMode -> Bool
-> Maybe (FilePath, [String])
-> IO (TreeView, ScrolledWindow, CellRendererText)
{- | Create an scrolled tree view with list stores containing an icon
from the file path and text associated with it from the string list.
The list stores can be set editable. -}
createStore title selmode iseditable xss =
do
scroll <- scrolledWindowNew Nothing Nothing
-- create the liststore.
store <- listStoreNew [TMobject, TMstring]
-- create treeview.
tv <- treeViewNewWithModel store
treeViewSetHeadersVisible tv True
sel <- treeViewGetSelection tv
treeSelectionSetMode sel selmode
-- cell renderer.
imagecell <- cellRendererPixbufNew
textcell <- cellRendererTextNew
-- is this cell editable?
objectSetPropertyBool "editable" textcell iseditable
tvc <- treeViewColumnNew
-- Sort columns.
treeViewColumnSetSortColumnId tvc 1
-- pack the column inside the view.
-- image cell.
treeViewColumnPackStart tvc imagecell False
treeViewColumnAddAttribute tvc imagecell "pixbuf" 0
-- text cell.
treeViewColumnPackEnd tvc textcell True
treeViewColumnAddAttribute tvc textcell "text" 1
treeViewColumnSetTitle tvc title
treeViewAppendColumn tv tvc
-- initialize listStore elements.
case xss of
Nothing -> return ()
Just (img, lst) -> storeObjects store img lst
-- add treeview into the scroll container.
containerAdd scroll tv
return (tv, scroll, textcell)
collectIters :: (TreeModelClass self) => self -> Int -> IO [TreeIter]
collectIters st n =
do
maybeiter <- treeModelGetIter st [n]
case maybeiter of
{ Nothing -> return []
; Just s -> collectIters st (n + 1) >>=
return . (s :) }
collectStringValues :: (TreeModelClass self) => self -> Int -> [TreeIter] -> IO [String]
collectStringValues store column =
mapM (\ iter -> do
string <- treeModelGetValue store iter column
case string of
GVstring Nothing -> return []
GVstring (Just string') -> return string'
_ -> popErrorWindow "collectStringValues: error?!" >>
return [])
storeObjects :: ListStore -> FilePath -> [String] -> IO ()
storeObjects st image =
mapM_ (\ file -> do
pixbuf <- pixbufNewFromFile image
i <- listStoreAppend st
listStoreSetValue st i 0 (GVobject (toGObject pixbuf))
listStoreSetValue st i 1 (GVstring (Just file)))
storeAndSelector :: [TreeView] -> IO [(ListStore, TreeSelection)]
storeAndSelector = mapM (\ tv -> do
store <- getStoreFromView tv
sel <- treeViewGetSelection tv
return (store, sel))
valueWithIterTreeModel :: ListStore -> Int -> Int -> IO GenericValue
valueWithIterTreeModel store node column =
do
jiter <- treeModelGetIter store [node]
case jiter of
Nothing -> error "valueWithIterTreeModel: error"
Just iter -> treeModelGetValue store iter column
getStoreFromView :: TreeView -> IO ListStore
getStoreFromView tv =
treeViewGetModel tv >>=
(\ s -> case s of
Nothing -> error "treeview got no valid treemodel."
Just treemodel -> return (castToListStore treemodel))
scrollViewToCell :: TreeModelClass a => a -> TreeIter -> TreeView -> IO ()
{- Scroll to a specific cell in the view. -}
scrollViewToCell tmodel iter tview =
do
treepath <- treeModelGetPath tmodel iter
(Just tvc) <- treeViewGetColumn tview 0
treeViewScrollToCell tview treepath tvc (Just (0,0))
getPackage :: FilePath -> TreeView -> IO (String, String, String, String)
getPackage portagerepo tv =
do
let getcategory = takeWhile (/= '/') . dropWhile (== ' ')
[(store, sel)] <- storeAndSelector [tv]
rows <- treeSelectionGetSelectedRows sel
case rows of
[[node]] -> do
(GVstring (Just pkg)) <- valueWithIterTreeModel store node textColumn
(Just tvc) <- treeViewGetColumn tv 0
(Just cat) <- treeViewColumnGetTitle tvc
return (portagerepo ++ cat ++ "/" ++ pkg ++ ".ebuild",
cat, pkg, "=" ++ (getcategory cat) ++ "/" ++ pkg)
_ -> return ([], [], [], [])
getEbuilds :: FilePath -> IO [String]
getEbuilds xs =
getDirectoryContents xs >>= \ f ->
return (filter (\ s -> reverse (fst (break (== '.') (reverse s))) == "ebuild") f)
getCategoryPackage :: TreeView -> ListStore -> TreeIter -> IO String
getCategoryPackage treev store node =
{-| Get the category name from the category
view column and concatenate it with the package name
for the full category/package atom. -}
do
(Just tvc) <- treeViewGetColumn treev 0
(Just pathlabel) <- treeViewColumnGetTitle tvc
(GVstring (Just pkgname)) <- treeModelGetValue store node textColumn
return $ ((++ "/") $ takeWhile (/= '/') pathlabel) ++ pkgname
{- | Operations around packages queue. -}
removeElement :: TreeView -> IO ()
removeElement pkgtv =
do
[(pkgst, sel)] <- storeAndSelector [pkgtv]
rows <- treeSelectionGetSelectedRows sel
case rows of
[] -> return ()
((node:[]):nodes) -> f node (length nodes)
where
f _ num | num < 0 = return ()
f node' num = do
a <- treeModelGetIter pkgst [node']
case a of
Nothing -> error "removeElement: error"
Just iter -> listStoreRemove pkgst iter >>
f node' (num - 1)
_ -> popErrorWindow "Util.hs, error: how it happened?"
addAtQueue :: TreeView -> Notebook -> Statusbar -> IO ()
addAtQueue fromtv panel statbar =
isCurrentPagePackagePanel panel func
where
func totv =
do
[(fromstore, sel), (tostore,_)] <- storeAndSelector [fromtv, totv]
maybeiter <- treeSelectionGetSelected sel
case maybeiter of
Nothing -> updateStatBar statbar "No package version selected."
(Just node) -> do
catpkg <- getCategoryPackage fromtv fromstore node
updateStatBar statbar (catpkg ++ " added to queue.")
pixbuf <- pixbufNewFromFile ebuildicon
storeQueueObjects tostore pixbuf [("A", catpkg)]
clearQueue :: TreeView -> IO ()
{- | Removed all the packages in the queue if any. -}
clearQueue = (listStoreClear =<<) . getStoreFromView
closeTab :: WidgetClass child => Notebook -> child -> IO ()
closeTab nb cd =
do
r <- notebookPageNum nb cd
case r of
Nothing -> popErrorWindow "Page doesn't exist."
Just num -> notebookRemovePage nb num
buttonWithIconLabel :: FilePath -> IO (Button, VBox)
{- | Create a button and associate it
with a respective icon -}
buttonWithIconLabel iconname =
do
box <- vBoxNew False 5
button <- buttonNew
label <- labelNew $ Just $ getfilename iconname
image <- imageNewFromFile iconname
buttonSetImage button image
buttonSetRelief button ReliefNone
containerAdd box button
containerAdd box label
return (button, box)
where
getfilename = takeWhile (/= '.') . reverse
. takeWhile (/= '/') . reverse
toolButton :: Tooltips -> Toolbar -> (String, String) -> IO ToolButton
{- | Create a toolbutton with a respective icon -}
toolButton tips toolbar (iconname, tip) =
do
image <- imageNewFromFile (iconpath ++ iconname ++ ".png")
tbutton <- toolButtonNew (Just image) (Just iconname)
toolbarInsert toolbar tbutton (-1)
toolItemSetTooltip tbutton tips tip []
return tbutton
cleanOutput :: String -> String
{- | Remove 'weird' escape characters from strings.
These are mainly generated by output commands. -}
cleanOutput str = case (unlines . map clean . lines) str of
[] -> []
xs -> init xs
where
clean [] = []
clean ('\BS':xs) = clean xs
clean ('\ESC':'[':'3':'1':';':'0':'1':'m':'q':xs) = clean xs
clean ('\ESC':'[':'0':'0':';':'0':'0':'m':xs) = clean xs
clean ('\ESC':'[':'3':'2':';':'0':'1':'m':xs) = clean xs
clean ('\ESC':'[':'0':'m':xs) = clean xs
clean ('\ESC':'[':'0':';':'3':'4':'m':xs) = clean xs
clean (x:xs) = x : clean xs
eixOutput :: String -> IO String
{- | eix operation -}
eixOutput pkg =
do
(_,out,_,ph) <- runInteractiveCommand (eixpath ++ pkg)
forkIO $ onExit ph f
hGetContents out >>= return . cleanOutput -- Clean weird chars on eix output.
where f _ = return ()
popEntryFunc :: String -> (String -> IO ()) -> IO ()
popEntryFunc msg func =
do
dia <- dialogNew
diabox <- dialogGetUpper dia
entrybox <- entryNew
set dia [ windowDefaultWidth := 400
, windowDefaultHeight := 90
, containerBorderWidth := 9 ]
label <- labelNew (Just msg)
boxPackStartDefaults diabox label
boxPackStartDefaults diabox entrybox
dialogAddButton dia stockOk ResponseOk
dialogAddButton dia stockCancel ResponseCancel
widgetShow label
widgetShow entrybox
dia `onResponse` onResponseSave dia entrybox
dialogRun dia
widgetDestroy dia
return ()
where
onResponseSave dia entrybox response =
case response of
ResponseCancel -> return ()
ResponseOk -> widgetDestroy dia >>
entryGetText entrybox >>= func
_ -> widgetDestroy dia >> return ()
readConfFile :: FilePath -> IO [String]
readConfFile = (=<<) (return . lines) . readFile
findAtom :: String -> String -> String
findAtom cs ts = f cs ts
where
f [] _ = []
f xs [] = takeWhile (/= '"') $ tail $ dropWhile (/= '"') xs
f (x:xs) (y:ys) | x == y = f xs ys | otherwise = f xs ts
readFileIfExist :: FilePath -> IO String
{- | Read a file.
Pops up an error window if it raises an exception. -}
readFileIfExist file =
do
b <- doesFileExist file
case b of
True -> readFile file
`E.catch`
(\ e -> (popErrorWindow $ show e) >> return [])
False -> return []
writeFileIfExist :: FilePath -> String -> IO ()
{- | Write a file.
Pops up an error window if it raises an exception. -}
writeFileIfExist file xs =
do
b <- doesFileExist file
case b of
True -> writeFile file xs
`E.catch`
(\ e -> popErrorWindow $ show e)
False -> return ()
readIfDirExist :: FilePath -> IO String
readIfDirExist file =
do
b <- doesDirectoryExist file
case b of
True -> getDirectoryContents file >>=
return . map ((file ++ "/") ++) . filterDirs [".",".."] >>=
(return . concat =<<) . (\ fl -> (mapM readFile fl)
`E.catch`
(\ e -> (popErrorWindow $ show e) >> return []))
False -> return []
writeTempFile :: String -> IO (FilePath, Handle)
writeTempFile = openTempFile "/tmp/"
strip, stripLeft, stripRight :: String -> String
stripLeft = dropWhile (== ' ')
stripRight = reverse . stripLeft . reverse
strip = stripLeft . stripRight
findRadioButton :: [(RadioButton, String)] -> IO String
findRadioButton [] = error "This should never happen!"
findRadioButton ((r,s):xs) =
do
active <- toggleButtonGetActive r
if active then return s else findRadioButton xs