himerge-0.18: 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, lookup)
import Data.Maybe (fromJust)
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, label, usevbox, textvuf, savebutton, quitbutton)
<- useFlagsWindow
-- Take each of the useflags into the proper radio buttons panel.
radiolist <- takeFlagsToRadio usevbox 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 :: [(String, VBox)] -> [String] -> IO [RadioFlag]
takeFlagsToRadio usevbox flags =
do
let useflags = ltouseflag flags
mapM (\ x@(UseFlag flag _ ) ->
case flag of
name | f 'a' name -> radio (lookupkey "a" usevbox) x
| f 'b' name -> radio (lookupkey "b" usevbox) x
| f 'c' name -> radio (lookupkey "c" usevbox) x
| f 'd' name -> radio (lookupkey "d" usevbox) x
| f 'e' name -> radio (lookupkey "e" usevbox) x
| f 'f' name -> radio (lookupkey "f" usevbox) x
| f 'g' name -> radio (lookupkey "g" usevbox) x
| f 'h' name -> radio (lookupkey "h" usevbox) x
| f 'i' name -> radio (lookupkey "i" usevbox) x
| f 'j' name -> radio (lookupkey "j" usevbox) x
| f 'k' name -> radio (lookupkey "k" usevbox) x
| f 'l' name -> radio (lookupkey "l" usevbox) x
| f 'm' name -> radio (lookupkey "m" usevbox) x
| f 'n' name -> radio (lookupkey "n" usevbox) x
| f 'o' name -> radio (lookupkey "o" usevbox) x
| f 'p' name -> radio (lookupkey "p" usevbox) x
| f 'q' name -> radio (lookupkey "q" usevbox) x
| f 'r' name -> radio (lookupkey "r" usevbox) x
| f 's' name -> radio (lookupkey "s" usevbox) x
| f 't' name -> radio (lookupkey "t" usevbox) x
| f 'u' name -> radio (lookupkey "u" usevbox) x
| f 'v' name -> radio (lookupkey "v" usevbox) x
| f 'w' name -> radio (lookupkey "w" usevbox) x
| f 'x' name -> radio (lookupkey "x" usevbox) x
| f 'y' name -> radio (lookupkey "y" usevbox) x
| f 'z' name -> radio (lookupkey "z" usevbox) x
| otherwise -> radio (lookupkey "S" usevbox) x) useflags
where
f = (flip (.) head) . (==)
ltouseflag = nub . map toUseFlag . filter (not . null) . sort
lookupkey k = fromJust . lookup k
useFlagsWindow :: IO (Window, Label, [(String, VBox)], 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
--
-- These are the different vboxes containing each of
-- the use flags inside notebook panels sorted by the
-- first letter alphabetically.
--
vboxA <- vBoxNew False 0
scrollA <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollA vboxA
vboxB <- vBoxNew False 0
scrollB <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollB vboxB
vboxC <- vBoxNew False 0
scrollC <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollC vboxC
vboxD <- vBoxNew False 0
scrollD <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollD vboxD
vboxE <- vBoxNew False 0
scrollE <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollE vboxE
vboxF <- vBoxNew False 0
scrollF <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollF vboxF
vboxG <- vBoxNew False 0
scrollG <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollG vboxG
vboxH <- vBoxNew False 0
scrollH <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollH vboxH
vboxI <- vBoxNew False 0
scrollI <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollI vboxI
vboxJ <- vBoxNew False 0
scrollJ <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollJ vboxJ
vboxK <- vBoxNew False 0
scrollK <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollK vboxK
vboxL <- vBoxNew False 0
scrollL <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollL vboxL
vboxM <- vBoxNew False 0
scrollM <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollM vboxM
vboxN <- vBoxNew False 0
scrollN <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollN vboxN
vboxO <- vBoxNew False 0
scrollO <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollO vboxO
vboxP <- vBoxNew False 0
scrollP <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollP vboxP
vboxQ <- vBoxNew False 0
scrollQ <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollQ vboxQ
vboxR <- vBoxNew False 0
scrollR <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollR vboxR
vboxS <- vBoxNew False 0
scrollS <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollS vboxS
vboxT <- vBoxNew False 0
scrollT <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollT vboxT
vboxU <- vBoxNew False 0
scrollU <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollU vboxU
vboxV <- vBoxNew False 0
scrollV <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollV vboxV
vboxW <- vBoxNew False 0
scrollW <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollW vboxW
vboxX <- vBoxNew False 0
scrollX <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollX vboxX
vboxY <- vBoxNew False 0
scrollY <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollY vboxY
vboxZ <- vBoxNew False 0
scrollZ <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollZ vboxZ
vboxSpecial <- vBoxNew False 0
scrollSpecial <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport scrollSpecial vboxSpecial
-- Use Flags panels assoc list.
let usevbox = [("a", vboxA), ("b", vboxB), ("c", vboxC)
, ("d", vboxD), ("e", vboxE), ("f", vboxF)
, ("g", vboxG), ("h", vboxH), ("i", vboxI)
, ("j", vboxJ), ("k", vboxK), ("l", vboxL)
, ("m", vboxM), ("n", vboxN), ("o", vboxO)
, ("p", vboxP), ("q", vboxQ), ("r", vboxR)
, ("s", vboxS), ("t", vboxT), ("u", vboxU)
, ("v", vboxV), ("w", vboxW), ("x", vboxX)
, ("y", vboxY), ("z", vboxZ), ("S", vboxSpecial)]
-- Add each use flag box to the respective panel.
mapM_ (\ (a, b) -> notebookAppendPage notebook a b)
[ (scrollA, "A"), (scrollB, "B"), (scrollC, "C")
, (scrollD, "D"), (scrollE, "E"), (scrollF, "F")
, (scrollG, "G"), (scrollH, "H"), (scrollI, "I")
, (scrollJ, "J"), (scrollK, "K"), (scrollL, "L")
, (scrollM, "M"), (scrollN, "N"), (scrollO, "O")
, (scrollP, "P"), (scrollQ, "Q"), (scrollR, "R")
, (scrollS, "S"), (scrollT, "T"), (scrollU, "U")
, (scrollV, "V"), (scrollW, "W"), (scrollX, "X")
, (scrollY, "Y"), (scrollZ, "Z"), (scrollSpecial, "Special") ]
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, label, usevbox, 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)