himerge-0.17.9: src/Menus.hs
{-
Code implementing menus windows and operations related to them.
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 Menus
where
import Util
import UseFlag
import Graphics.UI.Gtk
import System.Directory
import qualified Control.Exception as E
import System.IO
import Control.Monad (liftM2)
import Data.List (nub, sort)
{- | File Chooser code. -}
getChooser :: (IO FileChooserDialog) -> (FileChooserDialog -> IO (Maybe String))
-> (FilePath -> IO ()) -> IO ()
{- | Run specific dialog choosers. (Save pages and Open new repo) -}
getChooser dialog fctype okfunc =
do
dialog >>= \ fc ->
fc `onResponse` (fun fc) >>
widgetShowAll fc
where
fun fc ResponseOk =
do
file <- fctype fc
case file of
Nothing -> popErrorWindow "No valid file."
Just filename -> widgetDestroy fc >> okfunc filename
fun fc _ = widgetDestroy fc
{- | Save pages functions. These functions work together
with the filechooser functions. -}
allPages :: Notebook -> FilePath -> IO ()
allPages = (\ p s -> mapPanelPages p >>= allPageContents p
>>= writeFile s . unlines)
pageContents :: Notebook -> FilePath -> IO ()
pageContents panel filename =
do
num <- notebookGetCurrentPage panel
Just widgetpage <- notebookGetNthPage panel num
stringFromPage panel widgetpage >>= writeFile filename
storeModelValuesToString :: TreeModel -> IO String
storeModelValuesToString store = f 0 store >>= return . unlines
where
f index store' =
do
maybeiter <- treeModelGetIter store' [index]
case maybeiter of
Nothing -> return []
Just iter -> do
(GVstring (Just value)) <- treeModelGetValue store' iter 3
rvalue <- f (index + 1) store'
return (value : rvalue)
allPageContents :: Notebook -> [Widget] -> IO [String]
allPageContents = f
where
f _ [] = return []
f notebook (page:pagexs) =
do
xs <- stringFromPage notebook page
rxs <- f notebook pagexs
return (xs:rxs)
stringFromPage :: Notebook -> Widget -> IO String
stringFromPage notebook page =
do
scrollw <- return $ castToScrolledWindow page
text <- notebookGetMenuLabelText notebook scrollw
(Just c) <- binGetChild scrollw
case text of
Nothing -> error "stringFromPage: how this happened?!"
(Just text') -> do
if parse text'
then do
(Just store) <- treeViewGetModel (castToTreeView c)
storeModelValuesToString store
else do
textb <- textViewGetBuffer (castToTextView c)
startiter <- textBufferGetStartIter textb
enditer <- textBufferGetEndIter textb
textBufferGetText textb startiter enditer True
where
parse = liftM2 (||) ("Queue:" ==) ("Main" ==) . (!! 0) . words
mapPanelPages :: Notebook -> IO [Widget]
mapPanelPages = f 0
where
f num panel =
do
maybewidget <- notebookGetNthPage panel num
case maybewidget of
Nothing -> return []
Just sp -> do
rpage <- f (num + 1) panel
return (sp : rpage)
chooseIfDirectoryList :: [FilePath] -> [FilePath]
-> ([FilePath] -> IO ()) -> IO ()
{- Open fileChoosers for /etc/portage directories.
Use the respective files otherwise. -}
chooseIfDirectoryList [] tmpfiles applyfunc = applyfunc tmpfiles
chooseIfDirectoryList (pfile:pxs) tmpfiles applyfunc =
do
b <- doesDirectoryExist pfile
case b of
True -> do
fc <- fileChooserDialogNew (Just pfile) Nothing
FileChooserActionOpen
[("Ok", ResponseOk), ("Cancel", ResponseCancel)]
fileChooserSetCurrentFolder fc pfile
fc `onResponse` (fun fc)
widgetShowAll fc
where
fun fc ResponseOk =
do
file <- fileChooserGetFilename fc
case file of
Nothing -> widgetDestroy fc >> popErrorWindow "No valid file."
Just filename -> widgetDestroy fc >>
chooseIfDirectoryList pxs (filename : tmpfiles) applyfunc
fun fc _ = widgetDestroy fc
False -> chooseIfDirectoryList pxs (pfile : tmpfiles) applyfunc
{- | Code for windows showing different menus.
pop-up menu for packages versions and the package branch editor.-}
packagePopupMenu :: FilePath -> TreeView -> Statusbar -> Event -> IO Bool
{- | Package versions popup menu. -}
packagePopupMenu prepo tv statbar event@(Button { eventClick = ReleaseClick
, eventButton = RightButton }) =
getPackage prepo tv >>= flip packageMenuItems statbar >>=
flip menuPopup (Just (eventButton event, eventTime event)) >> return True
packagePopupMenu _ _ _ _ = return False
packageMenuItems :: (String, String, String, String) -> Statusbar -> IO Menu
packageMenuItems (ebuildpath, catpkg, pkg, key) statbar =
do
pkgmenu <- menuNew
-- adding package to files.
keywordall <- imageMenuItemNewWithLabel ("keyword all " ++ catpkg)
addallicon1 <- imageNewFromFile (iconpath ++ "small-add.png")
imageMenuItemSetImage keywordall addallicon1
keyword <- imageMenuItemNewWithLabel ("keyword " ++ pkg)
addicon1 <- imageNewFromFile (iconpath ++ "small-add.png")
imageMenuItemSetImage keyword addicon1
maskall <- imageMenuItemNewWithLabel ("mask all " ++ catpkg)
addallicon2 <- imageNewFromFile (iconpath ++ "small-add.png")
imageMenuItemSetImage maskall addallicon2
mask <- imageMenuItemNewWithLabel ("mask " ++ pkg)
addicon2 <- imageNewFromFile (iconpath ++ "small-add.png")
imageMenuItemSetImage mask addicon2
unmaskall <- imageMenuItemNewWithLabel ("unmask all " ++ catpkg)
addallicon3 <- imageNewFromFile (iconpath ++ "small-add.png")
imageMenuItemSetImage unmaskall addallicon3
unmask <- imageMenuItemNewWithLabel ("unmask " ++ pkg)
addicon3 <- imageNewFromFile (iconpath ++ "small-add.png")
imageMenuItemSetImage unmask addicon3
-- removing package from files.
rmkeywordall <- imageMenuItemNewWithLabel ("remove keyword all " ++ catpkg)
removeallicon1 <- imageNewFromFile (iconpath ++ "small-remove.png")
imageMenuItemSetImage rmkeywordall removeallicon1
rmkeyword <- imageMenuItemNewWithLabel ("remove keyword " ++ pkg)
removeicon1 <- imageNewFromFile (iconpath ++ "small-remove.png")
imageMenuItemSetImage rmkeyword removeicon1
rmmaskall <- imageMenuItemNewWithLabel ("remove mask all " ++ catpkg)
removeallicon2 <- imageNewFromFile (iconpath ++ "small-remove.png")
imageMenuItemSetImage rmmaskall removeallicon2
rmmask <- imageMenuItemNewWithLabel ("remove mask " ++ pkg)
removeicon2 <- imageNewFromFile (iconpath ++ "small-remove.png")
imageMenuItemSetImage rmmask removeicon2
rmunmaskall <- imageMenuItemNewWithLabel ("remove unmask all " ++ pkg)
removeallicon3 <- imageNewFromFile (iconpath ++ "small-remove.png")
imageMenuItemSetImage rmunmaskall removeallicon3
rmunmask <- imageMenuItemNewWithLabel ("remove keyword " ++ pkg)
removeicon3 <- imageNewFromFile (iconpath ++ "small-remove.png")
imageMenuItemSetImage rmunmask removeicon3
-- Add package use.
usepkg <- imageMenuItemNewWithLabel ("use package " ++ pkg)
addicon4 <- imageNewFromFile (iconpath ++ "small-add.png")
imageMenuItemSetImage usepkg addicon4
-- Add items to the menu binding to their respectives operations.
menuShellAppend pkgmenu usepkg
usepkg `onActivateLeaf`
do
allflags <- allUseFlags
ebuildc <- readFile ebuildpath
-- Strip '=' from =cat/pkgname (tail key).
-- Find the matched flags between the USE flags and IUSE of a package.
flagsfound <- return $ map (findIUSEonUSEFlags key allflags)
(words $ findAtom ebuildc "IUSE")
-- Open the use flag editor for this package version.
pkgUseFlags key $ concat flagsfound
-- Add and connect to the respectives operations each of the
-- menu items.
menuShellAppend pkgmenu keywordall
keywordall `onActivateLeaf`
chooseIfDirectoryList [packagekeywords] []
(\ (file:_) -> addPackageFor file catpkg >>
updateStatBar statbar (catpkg ++ " keyworded."))
menuShellAppend pkgmenu keyword
keyword `onActivateLeaf`
chooseIfDirectoryList [packagekeywords] []
(\ (file:_) -> addPackageFor file key >>
updateStatBar statbar (key ++ " keyworded."))
menuShellAppend pkgmenu maskall
maskall `onActivateLeaf`
chooseIfDirectoryList [packagemask] []
(\ (file:_) -> addPackageFor file catpkg >>
updateStatBar statbar (catpkg ++ " masked."))
menuShellAppend pkgmenu mask
mask `onActivateLeaf`
chooseIfDirectoryList [packagemask] []
(\ (file:_) -> addPackageFor file key >>
updateStatBar statbar (key ++ " masked."))
menuShellAppend pkgmenu unmaskall
unmaskall `onActivateLeaf`
chooseIfDirectoryList [packageunmask] []
(\ (file:_) -> addPackageFor file catpkg >>
updateStatBar statbar (catpkg ++ " unmasked."))
menuShellAppend pkgmenu unmask
unmask `onActivateLeaf`
chooseIfDirectoryList [packageunmask] []
(\ (file:_) -> addPackageFor file key >>
updateStatBar statbar (key ++ " unmasked."))
menuShellAppend pkgmenu rmkeywordall
rmkeywordall `onActivateLeaf`
chooseIfDirectoryList [packagekeywords] []
(\ (file:_) -> removePackageFrom file catpkg >>
updateStatBar statbar (catpkg ++ " removed keyworded."))
menuShellAppend pkgmenu rmkeyword
rmkeyword `onActivateLeaf`
chooseIfDirectoryList [packagekeywords] []
(\ (file:_) -> removePackageFrom file key >>
updateStatBar statbar (key ++ " removed keyworded."))
menuShellAppend pkgmenu rmmaskall
rmmaskall `onActivateLeaf`
chooseIfDirectoryList [packagemask] []
(\ (file:_) -> removePackageFrom file catpkg >>
updateStatBar statbar (catpkg ++ " removed mask."))
menuShellAppend pkgmenu rmmask
rmmask `onActivateLeaf`
chooseIfDirectoryList [packagemask] []
(\ (file:_) -> removePackageFrom file key >>
updateStatBar statbar (key ++ " removed mask."))
menuShellAppend pkgmenu rmunmaskall
rmunmaskall `onActivateLeaf`
chooseIfDirectoryList [packageunmask] []
(\ (file:_) -> removePackageFrom file catpkg >>
updateStatBar statbar (catpkg ++ " removed unmask."))
menuShellAppend pkgmenu rmunmask
rmunmask `onActivateLeaf`
chooseIfDirectoryList [packageunmask] []
(\ (file:_) -> removePackageFrom file key >>
updateStatBar statbar (key ++ " removed unmask."))
-- Show menu.
widgetShowAll pkgmenu
return pkgmenu
findIUSEonUSEFlags :: String -> [String] -> String -> [String]
{- This function finds the IUSE flags located either in the
local use flags and the global use flags list (all flags).
It tests for local use flags of the form: category/package:use - desc. ;
and matches against (category/package == catpkgname) and (use == iuse) to find
the correct local use flags of a package in the list of all flags. -}
findIUSEonUSEFlags catpkgname flags iuseflag =
filter (not . null) $ map f flags
where
f flag = let (h, t) = break (== ':') $ takeWhile (/= ' ') flag
in
case t of
[] -> if h == iuseflag then flag else []
(_:t') -> if (findSubstring h catpkgname)
then (if t' == iuseflag
then (tail $ dropWhile (/= ':') flag)
else [])
else []
addPackageFor, removePackageFrom :: FilePath -> String -> IO ()
addPackageFor = packageFile (\ k -> (k :))
removePackageFrom = packageFile (\ k -> filter (/= k))
packageFile :: (String -> ([String] -> [String]))
-> FilePath -> String -> IO ()
packageFile func = f
where
f path key = do
let writehandle wfileh = hPutStr wfileh . unlines . sort . nub . func key
createDirectoryIfMissing True etcpackage
fb <- doesFileExist path
list <- case fb of
True -> (do
rfileh <- openFile path ReadMode
str <- (hGetContents rfileh >>= E.evaluate)
hClose rfileh
return $ map strip $ lines str)
`E.catch`
(\ e -> (popErrorWindow $ show e) >>
return [])
False -> return []
(do
w <- openFile path WriteMode
writehandle w list
hClose w)
`E.catch`
(\ e -> popErrorWindow $ show e)
{- | Start code for the package branch editor window. -}
packageBranch :: IO ()
packageBranch =
chooseIfDirectoryList [ packageuse, packageunmask
, packagemask, packagekeywords ] [] showBranch
branchStore :: [FilePath] -> IO [(TreeView, ScrolledWindow, CellRendererText)]
branchStore =
mapM (\ file -> do
contents <- readFileIfExist file
createStore file SelectionMultiple True
(Just (packageicon, skipBCLines $ lines contents)))
where
skipBCLines = filter f
f [] = False
f ('#':_) = False
f _ = True
showBranch :: [FilePath] -> IO ()
{- | Package Branch Window. -}
showBranch [keywordsfile, maskfile, unmaskfile, usefile] =
do
window <- windowNew
panel <- notebookNew
notebookSetScrollable panel True
notebookSetPopup panel True
vbox <- vBoxNew False 9
[(keyview, keyscroll, keycell), (maskview, maskscroll, maskcell)
, (unmaskview, unmaskscroll, unmaskcell), (useview, usescroll, usecell)]
<- branchStore [keywordsfile, maskfile
, unmaskfile, usefile]
-- Add a logo.
image <- imageNewFromFile windowlogo
boxPackStart vbox image PackNatural 0
-- Add a horizontal separator.
notebookAppendPage panel keyscroll "Package Keywords"
notebookAppendPage panel maskscroll "Package Mask"
notebookAppendPage panel unmaskscroll "Package Unmask"
notebookAppendPage panel usescroll "Package Use"
-- Add the package branch panel into a frame.
branchframe <- makeFrame "Package Brach" 0.50 0.50
containerSetBorderWidth panel 9
containerAdd branchframe panel
-- Add the branch frame into the vbox.
boxPackStart vbox branchframe PackGrow 0
-- Add a horizontal separator
buttonbox <- hBoxNew False 0
removebutton <- buttonNewFromStock stockRemove
savebutton <- buttonNewFromStock stockSave
quitbutton <- buttonNewFromStock stockClose
boxPackStart buttonbox removebutton PackNatural 0
boxPackStart buttonbox savebutton PackNatural 0
boxPackStart buttonbox quitbutton PackNatural 0
boxPackStart vbox buttonbox PackNatural 0
removebutton `onClicked`
do
c <- notebookGetCurrentPage panel
case c of
0 -> removeElement keyview
1 -> removeElement maskview
2 -> removeElement unmaskview
3 -> removeElement useview
_ -> popErrorWindow "Components.hs - error: weird, how this happened?"
let list = [ (keyview, keywordsfile), (maskview, maskfile)
, (unmaskview, unmaskfile), (useview, usefile) ]
savebutton `onClicked`
popSelectWindow "Do you want to save this packages setup?"
(mapM_ (\ (view, file) -> do
store <- getStoreFromView view
str <- collectIters store 0 >>= collectStringValues store textColumn
writeFileIfExist file $ unlines str) list)
quitbutton `onClicked` widgetDestroy window
-- The cells of this treeview are editable.
keystore <- getStoreFromView keyview
usestore <- getStoreFromView useview
maskstore <- getStoreFromView maskview
unmaskstore <- getStoreFromView unmaskview
-- Update the tree store contents after edited.
afterEdited keycell keystore (editOn $ castToListStore keystore)
afterEdited usecell usestore (editOn $ castToListStore usestore)
afterEdited maskcell maskstore (editOn $ castToListStore maskstore)
afterEdited unmaskcell unmaskstore (editOn $ castToListStore unmaskstore)
set window [ windowTitle := "Himerge Package Branch"
, windowDefaultWidth := 600
, windowDefaultHeight := 500
, containerChild := vbox
, containerBorderWidth := 5 ]
widgetShowAll window
where
editOn store =
\ iter str ->
listStoreSetValue store iter textColumn (GVstring $ Just str)
showBranch _ = error "showBranch: How in the world did this happen?"