himerge-0.20: src/UseFlag.hs
{-
Functions to work around the USE flags.
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 UseFlag where
import Graphics.UI.Gtk
import Util
import Data.List (sort, nub, groupBy)
import Data.Char (isSpace)
type Variable = String
type Value = String
type AddType = String -> [RadioFlag] -> [EnvValues] -> IO String
data UseFlag = UseFlag String String
data RadioFlag = Radio String [RadioButton]
data EnvValues = EnvValue Variable Value | Comment String
deriving Show
instance Eq UseFlag where
UseFlag use _ == UseFlag use' _ = use == use'
useflagpath, localuseflagpath :: FilePath
useflaglabel :: String
useflagpath = "/usr/portage/profiles/use.desc"
localuseflagpath = "/usr/portage/profiles/use.local.desc"
useflaglabel = "Use Flags Enabled/Disabled:\n"
allUseFlags :: IO [String]
allUseFlags =
do
flags <- readGlobalFlagFile useflagpath
localflags <- readLocalFlagFile localuseflagpath
return (flags ++ localflags)
globalUseFlags :: IO ()
globalUseFlags = allUseFlags >>=
mapM (return . parseLocalUSE) >>=
useFlag makeconfpath addAtConf "USE"
parseLocalUSE :: String -> String
{- Test for local use flags and parse from <cat/pkg>:<use> <desc> to
<use> <desc>. -}
parseLocalUSE use =
let (_, t) = break (== ':') $ takeWhile (/= ' ') use
in
case t of
[] -> use
_ -> tail $ dropWhile(/= ':') use
pkgUseFlags :: String -> [String] -> IO ()
pkgUseFlags = useFlag packageuse addAtPkgUse
useFlag :: FilePath -> AddType
-> (String -> [String] -> IO ())
{- | Setup the USE flag window with the variable information. -}
useFlag usefile addfunc = usef
where
usef token [] =
popSelectWindow msg (allUseFlags >>= useFlag usefile addfunc token)
where
msg = "No ebuild use flag information.\nOpen the global use\
\ flag editor for this package?."
usef token useflags =
do
(window, notebook, label, textvuf, savebutton, quitbutton)
<- useFlagsWindow
-- Take each of the useflags into the proper radio buttons panel.
radiolist <- takeFlagsToRadio notebook useflags
-- Read the make.conf or package.use flag, depending
-- if we are using the global use flag editor or the
-- package specific use flag editor.
b <- readFileIfExist usefile
case b of
[] -> popErrorWindow (usefile ++ " error reading file.")
xs -> do
let char = (if token == "USE" then '=' else ' ')
-- Parse the configuration files.
let usefileparsed = parseConf $ map (dropWhile isSpace) $ lines xs
envvalues <- mkEnvValues char usefileparsed
updateTextBuffer textvuf $ getcurrentflags envvalues
-- activate use flags.
mapM_ (activateUseFlags token (words $ getEnvValue token envvalues)) radiolist
labelSetMarkup label ("<i>Listing " ++ (show (length radiolist))
++ " flags for " ++ token ++ "</i>")
savebutton `onClicked`
popSelectWindow "Do you want to save this USE flags setup?"
(do
addfunc token radiolist envvalues >>=
writeFileIfExist usefile
ys <- readFileIfExist usefile
(if null b
then mkEnvValues char usefileparsed
else mkEnvValues char (lines ys)) >>=
updateTextBuffer textvuf . getcurrentflags)
quitbutton `onClicked` widgetDestroy window >> return ()
{- Main creation call routine for hUFE -}
widgetShowAll window
where
-- Current USE flags setup. Add a newline for pretty printing.
getcurrentflags = unwords . map (++ "\n") . words . getEnvValue token
toUseFlag :: String -> UseFlag
toUseFlag xs = let (use, (_:desc)) = break (== ' ') xs
in UseFlag use desc
activateUseFlags :: String -> [String] -> RadioFlag -> IO ()
{- Activate the radioflags for each USE flags enabled or disabled.
Consider local use flags of the form: category/package:useflag to test for validity. -}
activateUseFlags _ [] (Radio _ (_:_:r:[])) = toggleButtonSetActive r True
activateUseFlags varpkg (('-':use):ufxs) radion@(Radio uf (_:n:_:[]))
| (use == uf) || (use == ((last . splitStr ':') uf)) && (findSubstring ((head . splitStr ':') uf) varpkg) = toggleButtonSetActive n True
| otherwise = activateUseFlags varpkg ufxs radion
activateUseFlags varpkg (use:ufxs) radiop@(Radio uf (p:_:_:[]))
| (use == uf) || (use == ((last . splitStr ':') uf)) && (findSubstring ((head . splitStr ':') uf) varpkg)= toggleButtonSetActive p True
| otherwise = activateUseFlags varpkg ufxs radiop
activateUseFlags _ _ _ = popErrorWindow "Error activating use flag buttons."
checkUseFlags :: RadioFlag -> IO String
checkUseFlags (Radio uf (p:n:_:[])) =
do
let f = last $ splitStr ':' uf
b <- toggleButtonGetActive p
if b
then return f
else do
tb <- toggleButtonGetActive n
if tb then return ('-':f) else return []
checkUseFlags _ = return []
mkEnvValues :: Char -> [String] -> IO [EnvValues]
mkEnvValues sep =
mapM (\ xs -> if null xs || head xs == '#' || checkifknown xs
then return (Comment xs)
else do
let (var, (_:val)) = break (== sep) xs
return (EnvValue var val))
where
-- Check if the token is a valid make.conf command,
-- so we parse correct values between make.conf and package.use
checkifknown = flip any knowncmd . (==) . head . words
knowncmd = ["source"]
insertVariable :: EnvValues -> [EnvValues] -> [EnvValues]
insertVariable env [] = env : []
insertVariable ins@(EnvValue var _) (out@(EnvValue var' _):exs)
| var == var' = ins : exs
| otherwise = out : insertVariable ins exs
insertVariable env (envvalues:xs) = envvalues : insertVariable env xs
envValuetoString :: String -> EnvValues -> String
envValuetoString _ (EnvValue _ []) = []
envValuetoString s (EnvValue var val) = var ++ s ++ val
envValuetoString _ (Comment xs) = xs
radio :: VBox -> UseFlag -> IO RadioFlag
radio vbox (UseFlag useflag desc) =
do
hbox <- hBoxNew False 0
radio1 <- radioButtonNewWithLabel "+"
radio2 <- radioButtonNewWithLabel "-"
radio3 <- radioButtonNewWithLabel (useflag ++ desc)
radioButtonSetGroup radio1 radio3
radioButtonSetGroup radio2 radio3
toggleButtonSetActive radio3 True
boxPackStart hbox radio1 PackNatural 0
boxPackStart hbox radio2 PackNatural 0
boxPackStart hbox radio3 PackNatural 0
boxPackStartDefaults vbox hbox
return (Radio useflag [radio1, radio2, radio3])
readGlobalFlagFile, readLocalFlagFile :: FilePath -> IO [String]
readGlobalFlagFile = readFlagFile
readLocalFlagFile = readFlagFile
readFlagFile :: FilePath -> IO [String]
readFlagFile = (=<<) (return . filter (/= []) .
map (\ xs -> case xs of
{ [] -> [] ; ('#':_) -> [] ; ys -> ys }) .
lines) . readFile
parseConf :: [String] -> [String]
-- This functions takes care of properly parsing the USE flag
-- enviroment variable from the configuration files.
-- make.conf might have '\' newline separators, so fix that.
parseConf [] = []
parseConf y@(x:xs) | (not . null) x && last x == '\\' =
let (a, b) = f y [] in a : parseConf b
| otherwise = x : parseConf xs
where
f [] str = (str, [])
f (z:zs) str | last z == '\\' = f zs (str ++ init z)
| otherwise = (str ++ z, zs)
takeFlagsToRadio :: Notebook -> [String] -> IO [RadioFlag]
takeFlagsToRadio notebook flags =
do
let useflags = ltouseflag flags
radiolist <- mapM (\ groupflags ->
do
let (UseFlag flag _) = head groupflags
vbox <- createFlagBox [ head flag]
mapM (radio vbox) groupflags) (groupFlags useflags)
return $ concat radiolist
where
groupFlags = groupBy (\ (UseFlag a _) (UseFlag b _) -> (head a) == (head b))
createFlagBox name =
do
vbox <- vBoxNew False 0
scroll <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scroll vbox
notebookAppendPage notebook scroll name
return vbox
ltouseflag = nub . map toUseFlag . filter (not . null) . sort
useFlagsWindow :: IO (Window, Notebook, Label, TextView, Button, Button)
{- | Create USE Flag Window. -}
useFlagsWindow =
do
window <- windowNew
mainbox <- vBoxNew False 5
mainvbox <- vBoxNew False 9
mainpaned <- hPanedNew
cflagbox <- vBoxNew False 5
(statscroll, statview) <- makeView False
-- Add logo.
image <- imageNewFromFile windowlogo
boxPackStart mainbox image PackNatural 0
-- List the current setup of USE flags.
currentflagsvbox <- vBoxNew False 9
boxPackStart currentflagsvbox statscroll PackGrow 0
-- Pack the current USE flags inside a box.
cflag <- labelNew $ Just "Current Flags Setup"
hsep <- hSeparatorNew
boxPackStart cflagbox cflag PackNatural 0
boxPackStart cflagbox hsep PackNatural 0
cframe <- frameNew
containerAdd cframe currentflagsvbox
boxPackStart cflagbox cframe PackGrow 3
panedAdd1 mainpaned cflagbox
-- The main radiobutton widget listing all
-- the USE flags.
notebook <- notebookNew
notebookSetPopup notebook True
panedAdd2 mainpaned notebook
boxPackStart mainvbox mainpaned PackGrow 5
-- Make main frame.
mainframe <- makeFrame "USE Flags" 0.50 0.50
containerSetBorderWidth mainvbox 9
containerAdd mainframe mainvbox
-- Add the main frame to the mainbox.
boxPackStart mainbox mainframe PackGrow 0
-- Usage explanation.
label <- labelNew Nothing
usagelabel <- labelNew $ Just "[+] Enable | [-] Disable"
boxPackStart mainbox label PackNatural 0
boxPackStart mainbox usagelabel PackNatural 0
-- Create the button box: save, close.
buttonbox <- hBoxNew False 0
savebutton <- buttonNewFromStock stockSave
quitbutton <- buttonNewFromStock stockClose
-- pack the 'Save' and 'Quit' button.
boxPackStart buttonbox savebutton PackNatural 0
boxPackStart buttonbox quitbutton PackNatural 0
boxPackStart mainbox buttonbox PackNatural 0
containerAdd window mainbox
set window [ windowTitle := "Himerge USE Flags Editor"
, windowDefaultWidth := 700
, windowDefaultHeight := 400
, containerBorderWidth := 5 ]
return (window, notebook, label, statview, savebutton, quitbutton)
getEnvValue :: String -> [EnvValues] -> String
getEnvValue _ [] = []
getEnvValue pkgname ((EnvValue pkg value):xs)
| pkgname == pkg = filter (/= '"') value
| otherwise = getEnvValue pkgname xs
getEnvValue pkgname (_:xs) = getEnvValue pkgname xs
addAtConf, addAtPkgUse :: AddType
addAtConf = addAt "=" show id
addAtPkgUse = addAt " " id (sort . filter (/= []))
addAt :: String -> (String -> String)
-> ([String] -> [String]) -> AddType
addAt sep func funcord = af
where
af value radiolist envlist =
mapM checkUseFlags radiolist >>=
return . unlines . funcord . map (envValuetoString sep) .
flip insertVariable envlist . EnvValue value . func . unwords .
nub . filter (not . null)