imported fquery-0.2v0.2
authorSergei Trofimovich <slyfox@inbox.ru>
Wed, 22 Apr 2009 19:43:07 +0000 (22 22:43 +0300)
committerSergei Trofimovich <slyfox@inbox.ru>
Wed, 22 Apr 2009 19:43:07 +0000 (22 22:43 +0300)
Signed-off-by: Sergei Trofimovich <slyfox@inbox.ru>
24 files changed:
Adelie/Colour.hs
Adelie/Config.hs.in [new file with mode: 0644]
Adelie/Contents.hs
Adelie/Depend.hs
Adelie/ListEx.hs
Adelie/Options.hs [new file with mode: 0644]
Adelie/Portage.hs
Adelie/Pretty.hs
Adelie/QChangelog.hs
Adelie/QCheck.hs
Adelie/QList.hs
Adelie/QOwn.hs
Adelie/QSize.hs
Adelie/QUse.hs
Adelie/QWant.hs
Adelie/Use.hs
Adelie/UseDesc.hs
Adelie/opts.c [new file with mode: 0644]
Adelie/opts.h [new file with mode: 0644]
Main.hs [changed mode: 0644->0755]
Makefile [deleted file]
Setup.hs [new file with mode: 0755]
configure [new file with mode: 0755]
fquery.cabal [new file with mode: 0644]

dissimilarity index 77%
index 853e22c..c9b88b5 100644 (file)
@@ -1,27 +1,55 @@
--- Colour.hs
---
--- Escape codes for colouring in output.
-
-module Adelie.Colour (
-    gray,
-    red,
-    green,
-    yellow,
-    blue,
-    magenta,
-    cyan,
-    white,
-    off,
-    off2
-) where
-
-gray    = putStr "\27[30;01m"
-red     = putStr "\27[31;01m"
-green   = putStr "\27[32;01m"
-yellow  = putStr "\27[33;01m"
-blue    = putStr "\27[34;01m"
-magenta = putStr "\27[35;01m"
-cyan    = putStr "\27[36;01m"
-white   = putStr "\27[37;01m"
-off     = putStr "\27[0m"
-off2    = putStrLn "\27[0m"
+-- Colour.hs
+--
+-- Escape codes for colouring in output.
+
+module Adelie.Colour (
+    gray,     inGray,
+    red,      inRed,
+    green,    inGreen,
+    yellow,   inYellow,
+    blue,     inBlue,
+    magenta,  inMagenta,
+    cyan,     inCyan,
+    white,    inWhite,
+    off,
+    off2
+) where
+
+import Monad (when)
+
+import Adelie.Options
+
+gray, red, green, yellow, blue, magenta, cyan, white, off, off2 :: IO ()
+
+gray    = whenM colourEnabled $ putStr "\27[30;01m"
+red     = whenM colourEnabled $ putStr "\27[31;01m"
+green   = whenM colourEnabled $ putStr "\27[32;01m"
+yellow  = whenM colourEnabled $ putStr "\27[33;01m"
+blue    = whenM colourEnabled $ putStr "\27[34;01m"
+magenta = whenM colourEnabled $ putStr "\27[35;01m"
+cyan    = whenM colourEnabled $ putStr "\27[36;01m"
+white   = whenM colourEnabled $ putStr "\27[37;01m"
+off     = whenM colourEnabled $ putStr "\27[0m"
+off2    = do
+  true <- colourEnabled
+  if true
+    then putStrLn "\27[0m"
+    else putChar '\n'
+
+whenM :: IO Bool -> IO () -> IO ()
+whenM cond f = cond >>= (flip when f)
+
+----------------------------------------------------------------
+
+inGray, inRed, inGreen, inYellow    :: IO () -> IO ()
+inBlue, inMagenta, inCyan, inWhite  :: IO () -> IO ()
+
+inGray    f = gray    >> f >> off
+inRed     f = red     >> f >> off
+inGreen   f = yellow  >> f >> off
+inYellow  f = yellow  >> f >> off
+inBlue    f = blue    >> f >> off
+inMagenta f = magenta >> f >> off
+inCyan    f = cyan    >> f >> off
+inWhite   f = white   >> f >> off
+
diff --git a/Adelie/Config.hs.in b/Adelie/Config.hs.in
new file mode 100644 (file)
index 0000000..674175a
--- /dev/null
@@ -0,0 +1,13 @@
+-- Config.hs
+--
+-- Auto-generated.
+
+module Adelie.Config (
+  portageTree,
+  portageDB
+) where
+
+portageTree, portageDB :: String
+
+portageTree = @@PortageTree@@
+portageDB = @@PortageDB@@
index f679a23..4fa4459 100644 (file)
@@ -33,13 +33,17 @@ contentsFromCatName (cat, name) = concatPath [portageDB,cat,name,"CONTENTS"]
 
 readContents :: (Contents -> a -> IO (Bool, a)) -> FilePath -> a -> IO a
 readContents f fn a = do
-  fp <- openFile fn ReadMode
-  a' <- readContents' f fp a
-  hClose fp
-  return a'
-
-readContents' :: (Contents -> a -> IO (Bool, a)) -> Handle -> a -> IO a
-readContents' f fp a = do
+  r <- try read
+  case r of
+    Left  _  -> return a
+    Right a' -> return a'
+  where
+    read = (bracket (openFile fn ReadMode)
+                    hClose
+                    (readContents' f a))
+
+readContents' :: (Contents -> a -> IO (Bool, a)) -> a -> Handle -> IO a
+readContents' f a fp = do
   eof <- hIsEOF fp
   if eof
     then return a
@@ -48,7 +52,7 @@ readContents' f fp a = do
       (done, a') <- f (contentsParser ln) a
       if done
         then return a'
-        else readContents' f fp a'
+        else readContents' f a' fp
 
 ----------------------------------------------------------------
 
index c31e0a6..eab3c34 100644 (file)
@@ -39,10 +39,11 @@ dependFromCatName (cat, name) = concatPath [portageDB,cat,name,"RDEPEND"]
 
 readDepend :: FilePath -> [String] -> IO [Dependency]
 readDepend fn iUse = do
-  r <- parseFromFile (dependParser iUse) fn
+  r <- (start_parser fn) `catch` (\ _ -> return $ Right [])
   case r of
     Left err -> putStr "Parse error at " >> print err >> error "Aborting"
     Right x  -> return $ nub x
+  where start_parser = parseFromFile (dependParser iUse)
 
 ----------------------------------------------------------------
 
index fd713d3..2bf6e00 100644 (file)
@@ -7,11 +7,14 @@ module Adelie.ListEx (
   concatMapM,
   digitsToInt,
   dropTail,
+  dropUntilAfter,
+  foldMUntil,
   pad
 ) where
 
-import Char   (digitToInt)
-import Monad  (liftM)
+import Char       (digitToInt)
+import Data.List  (foldl')
+import Monad      (liftM)
 
 ----------------------------------------------------------------
 
@@ -23,10 +26,21 @@ concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
 concatMapM f xs = liftM concat $ mapM f xs
 
 digitsToInt :: String -> Int
-digitsToInt = foldl (\ a b -> a*10 + digitToInt b) 0
+digitsToInt = foldl' (\ a b -> a*10 + digitToInt b) 0
 
 dropTail :: Int -> [a] -> [a]
 dropTail n s = take (length s-n) s
 
+dropUntilAfter :: (a -> Bool) -> [a] -> [a]
+dropUntilAfter f = dropWhile f . dropWhile (not.f)
+
+foldMUntil :: Monad m => (a -> b -> m a) -> (a -> Bool) -> a -> [b] -> m a
+foldMUntil _ _ a [] = return a
+foldMUntil f g a (x:xs) = do
+  a' <- f a x
+  case g a' of
+    True  -> return a'
+    False -> foldMUntil f g a' xs
+
 pad :: Int -> a -> [a] -> [a]
-pad n a str = str ++ (replicate (n-length str) a)
+pad n a str = take n (str ++ repeat a)
diff --git a/Adelie/Options.hs b/Adelie/Options.hs
new file mode 100644 (file)
index 0000000..3a26dfd
--- /dev/null
@@ -0,0 +1,13 @@
+{-# OPTIONS -fglasgow-exts #-}
+
+-- Options.hs
+--
+-- We keep some globals in C so we don't have to pass them around everywhere.
+
+module Adelie.Options (
+  colourEnabled,
+  setColourEnabled
+) where
+
+foreign import ccall unsafe "opts.h colour_enabled" colourEnabled :: IO Bool
+foreign import ccall unsafe "opts.h set_colour_enabled" setColourEnabled :: Bool -> IO ()
index f41105d..b998dad 100644 (file)
@@ -21,13 +21,8 @@ import List       (intersperse, sort)
 import Monad      (liftM)
 
 import Adelie.ListEx
+import Adelie.Config
 
-portageTree :: String
-portageTree = "/usr/portage"
-
--- Where portage's database is located.
-portageDB :: String
-portageDB = "/var/db/pkg"
 
 portageProfiles :: String
 portageProfiles = portageTree ++ "/profiles"
index bc4baec..d1a4ea4 100644 (file)
@@ -19,7 +19,7 @@ putCatNameLn = putCatName' off2
 
 putCatName' :: IO () -> (String, String) -> IO ()
 putCatName' f (c, n) =
-  yellow >> putStr c >> off >> putChar '/' >> yellow >> putStr n >> f
+  inYellow (putStr c) >> putChar '/' >> yellow >> putStr n >> f
 
 ----------------------------------------------------------------
 
index baf54a3..cccb938 100644 (file)
 -- Module to find the changelog of a package.
 
 module Adelie.QChangelog (
-  qChangelog
+  qChangelog,
+  qLogFile
 ) where
 
+import Char   (isAlpha, isDigit, isSpace)
+import Monad  (unless)
+
+import Adelie.Colour
+import Adelie.CompareVersion
+import Adelie.ListEx
 import Adelie.Portage
+import Adelie.Pretty
+
+----------------------------------------------------------------
+
+qLogFile :: [String] -> IO ()
+qLogFile args = mapM_ (putStrLn.logFile) =<< findInstalledPackages args
+
+logFile :: (String, String) -> String
+logFile (cat, name) = 
+  portageTree ++ '/':cat ++ '/':(dropVersion name) ++ "/ChangeLog"
 
 ----------------------------------------------------------------
 
 qChangelog :: [String] -> IO ()
-qChangelog [] = return ()
-qChangelog args = mapM_ changelog =<< findInstalledPackages args
+qChangelog []       = return ()
+qChangelog [x]      = mapM_ (changelog Nothing)  =<< findInstalledPackages [x]
+qChangelog (x:y:_)  = mapM_ (changelog (Just y)) =<< findInstalledPackages [x]
+
+changelog :: Maybe String -> (String, String) -> IO ()
+changelog end catname@(_, name) = do
+  putStr "ChangeLog since " >> putCatNameLn catname
+  log <- readFile (logFile catname)
+  puts name end log
+
+----------------------------------------------------------------
+
+puts :: String -> Maybe String -> String -> IO ()
+
+puts _ _ [] = return ()
+puts inst end ('#':l) = puts inst end (dropUntilAfter isNewLine l)
+
+puts inst end ('*':l0) = do
+  case maybeCompareVersion package end of
+    GT -> puts inst end next
+    otherwise -> case compareVersion inst package of
+      LT -> putSection package date >> putDesc ls >> puts inst end next
+      otherwise -> puts inst end next
+  where (section, next) = breakSection l0
+        (line, ls) = break2 isNewLine section
+        (l1, l2) = break2 ('(' ==) line
+        package = takeWhile (not.isSpace) l1
+        date = takeWhile (')' /=) l2
+
+puts inst end (_:ls) = puts inst end ls
+
+maybeCompareVersion :: String -> Maybe String -> Ordering
+maybeCompareVersion _ Nothing   = LT
+maybeCompareVersion a (Just b)  = compareVersion a b
+
+----------------------------------------------------------------
+
+breakSection :: String -> (String, String)
+breakSection str = (reverse h, t)
+  where (h, t) = breakSection' [] str
+
+breakSection' :: String -> String -> (String, String)
+breakSection' acc [] = (acc, [])
+breakSection' acc nx@('\n':'*':_) = (acc, nx)
+breakSection' acc (x:xs) = breakSection' (x:acc) xs
+
+----------------------------------------------------------------
+
+putSection :: String -> String -> IO ()
+putSection package date = do
+  putStr "* " >> inYellow (putStr package) 
+  putStr " (" >> inWhite (putStr date) >> putStrLn ")"
+
+----------------------------------------------------------------
+
+putDesc :: String -> IO ()
+putDesc [] = return ()
+putDesc str = mapM_ putDesc' ls
+  where ls = doublelines (dropWhile isNewLine str)
+
+putDesc' :: String -> IO ()
+putDesc' str = do
+  if beginsWithDate (dropWhile isSpace str)
+    then do
+      putHeader header
+      putBody body
+    else
+      putBody str
+  where str1 = dropWhile isSpace str
+        (header, body) = break2 (':' ==) str
+
+doublelines :: String -> [String]
+doublelines str =
+  case t of
+    []           -> h : []
+    (_:'\n':xs)  -> h : doublelines xs
+    (_:xs)       -> let (l0:l1) = doublelines xs 
+                    in (h ++ ('\n' : l0)) : l1
+  where (h, t) = break ('\n' ==) str
+
+beginsWithDate :: String -> Bool
+beginsWithDate []   = False
+beginsWithDate [_]  = False
+beginsWithDate (x:y:xs)
+  | not (isDigit x)         = False
+  | not (isDigitOrSpace y)  = False
+  | otherwise = True
+
+----------------------------------------------------------------
+
+putHeader :: String -> IO ()
+putHeader str0 = do
+  putChar '\n'
+  inWhite (putStr date)
+  unless (null name) (putStr name)
+  red >> putStr ('<':mail) >> putChar '>' >> off2
+  putStr "    " >> putFiles 76 files
+  where
+    (date, str1) = break2 (';' ==) str0
+    (name, str2) = break2 ('<' ==) str1
+    (mail, str3) = break2 ('>' ==) str2
+    files = words str3
+
+putFiles :: Int -> [String] -> IO ()
+putFiles _ [] = putChar '\n'
+putFiles rem (";":files) = putFiles rem files
+putFiles rem (f:files) =
+  if rem < len
+    then do
+      putChar '\n' >> putStr "    "
+      putFiles 76 (f:files)
+    else do
+      cyan
+      if (last f == ',')
+        then putStr (dropTail 1 f) >> off >> putStr ", "
+        else putStr f >> off >> putChar ' '
+      putFiles (rem-len-1) files
+  where len = length f
+
+----------------------------------------------------------------
+
+putBody :: String -> IO ()
+putBody [] = putChar '\n'
+
+putBody ('#':c0) =
+  case bug of
+    [] -> putChar '#' >> putBody cs
+    otherwise -> inMagenta (putStr ('#':bug)) >> putBody cs
+  where (bug, cs) = span (isDigitOrSpace) c0
+
+putBody (c:cs) = putChar c >> putBody cs
+
+----------------------------------------------------------------
+
+isNewLine :: Char -> Bool
+isNewLine '\n'  = True
+isNewLine _     = False
 
-changelog :: (String, String) -> IO ()
-changelog (cat, name) = do
-  putStrLn $ portageTree ++ fullname ++ "/ChangeLog"
-  where fullname = '/':cat ++ '/':(dropVersion name)
+isDigitOrSpace :: Char -> Bool
+isDigitOrSpace x = isDigit x || isSpace x
index 2bbc2fa..9b4803a 100644 (file)
@@ -23,7 +23,6 @@ type Count = (Int, Int)
 ----------------------------------------------------------------
 
 qCheck :: [String] -> IO ()
-qCheck [] = return ()
 qCheck args = mapM_ check =<< findInstalledPackages args
 
 check :: (String, String) -> IO ()
@@ -42,7 +41,7 @@ check' (Obj o m _) (g, b) = do
   r <- try (getFileStatus o)
   case r of
     Left e -> do
-      red >> putStr "!!! " >> off >> putStr o >> putStrLn " does not exist"
+      inRed (putStr "!!! ") >> putStr o >> putStrLn " does not exist"
       return (False, (g, b+1))
     Right stat -> do
       (rd, wr) <- createPipeHandle
@@ -74,4 +73,4 @@ runMD5sum f stdout = runProcess md5sum [f] Nothing Nothing stdin stdout stderr
 
 putMD5error :: String -> IO ()
 putMD5error file =
-  red >> putStr "!!! " >> off >> putStrLn (file ++ " has incorrect md5sum")
+  inRed (putStr "!!! ") >> putStrLn (file ++ " has incorrect md5sum")
index 156223c..c66b5a5 100644 (file)
@@ -22,7 +22,6 @@ data ListTypes
 ---------------------------------------------------------------- 
 
 qList :: ListTypes -> [String] -> IO ()
-qList _ [] = return ()
 qList types args = mapM_ (list puts) =<< findInstalledPackages args
   where
     puts = case types of
index 69931d4..db301c9 100644 (file)
@@ -8,11 +8,12 @@ module Adelie.QOwn (
 ) where
 
 import List       (delete)
-import Monad      (foldM, when)
+import Monad      (when)
 import Text.Regex (Regex, matchRegex, mkRegex)
 
 import Adelie.Colour
 import Adelie.Contents
+import Adelie.ListEx
 import Adelie.Portage
 import Adelie.Pretty
 
@@ -21,11 +22,10 @@ import Adelie.Pretty
 qOwn :: [String] -> IO ()
 qOwn [] = return ()
 qOwn args = do
-  foldM qOwn' args =<< allInstalledPackages
+  foldMUntil qOwn' null args =<< allInstalledPackages
   putChar '\n'
 
 qOwn' :: [String] -> (String, String) -> IO [String]
-qOwn' [] _ = return []
 qOwn' files catname = readContents (puts catname) contents files
   where contents = contentsFromCatName catname
 
@@ -37,7 +37,7 @@ puts catname c fs =
     then do
       let fs' = deleteContent c fs
       putCatName catname >> putStr " (" >> putContents c >> putStrLn ")"
-      return (fs' == [], fs')
+      return (null fs', fs')
     else
       return (False, fs)
 
index 0f5d6c2..480c2fc 100644 (file)
@@ -21,7 +21,6 @@ type Count = (FileOffset, Int, Int, Int, Int)
 ----------------------------------------------------------------
 
 qSize :: [String] -> IO ()
-qSize [] = return ()
 qSize args = mapM_ size =<< findInstalledPackages args
 
 size :: (String, String) -> IO ()
index 2b2244d..8701746 100644 (file)
@@ -17,7 +17,6 @@ import Adelie.UseDesc
 ----------------------------------------------------------------
 
 qUse :: [String] -> IO ()
-qUse [] = return ()
 qUse args = qUse' =<< findInstalledPackages args
 
 qUse' :: [(String, String)] -> IO ()
index 2832d4b..f886fdc 100644 (file)
@@ -12,7 +12,6 @@ import Adelie.Use
 -------------------------------------------------------------
 
 qWant :: [String] -> IO ()
-qWant []   = return ()
 qWant args = mapM_ qWant' =<< findInstalledPackages args
 
 qWant' :: (String, String) -> IO ()
index 496d95e..2f4821b 100644 (file)
@@ -26,9 +26,9 @@ iUseFromCatName (cat, name) = concatPath [portageDB,cat,name,"IUSE"]
 ----------------------------------------------------------------
 
 readUse :: FilePath -> IO [String]
-readUse fn = liftM words (readFile fn)
+readUse fn = (liftM words $ readFile fn) `catch` (\ _ -> return [])
 
 -- IUSE files sometimes have duplicate USE flags.  I am not sure if it is the
 -- intended behaviour, but I filter them out.
 readIUse :: FilePath -> IO [String]
-readIUse fn = liftM (nub.sort.words) (readFile fn)
+readIUse fn = (liftM (nub.sort.words) $ readFile fn) `catch` (\ _ -> return [])
dissimilarity index 65%
index e64a04e..4afb726 100644 (file)
--- UseDesc.hs
---
--- Module for parsing portageProfile/use.desc and use.local.desc files.
-
-module Adelie.UseDesc (
-  UseDescriptions,
-  readUseDesc,
-  readUseDescPackage
-) where
-
-import Data.HashTable as HashTable
-import Text.ParserCombinators.Parsec
-
-import Adelie.Portage
-
-type UseDesc = (String, String)
-type UseDescriptions = HashTable String String
-
-----------------------------------------------------------------
-
-genReadDesc :: Parser [UseDesc] -> String -> IO [UseDesc]
-genReadDesc p fn = do
-  r <- parseFromFile p fn
-  case r of
-    Left err -> putStr "Parse error at " >> print err >> error "Aborting"
-    Right x  -> return x
-
-----------------------------------------------------------------
-
-readUseDesc :: IO UseDescriptions
-readUseDesc = genReadDesc useParser useDesc >>= HashTable.fromList hashString
-
-useParser :: Parser [UseDesc]
-useParser = useParser' `sepEndBy` newline
-
-useParser' :: Parser UseDesc
-useParser' = parseComment useParser'
-         <|> parseUse
-
-----------------------------------------------------------------
-
-readUseDescPackage :: String -> String -> IO UseDescriptions
-readUseDescPackage start end = 
-  genReadDesc (useParser2 start end) useDescPackage >>=
-  HashTable.fromList hashString
-
-useParser2 :: String -> String -> Parser [UseDesc]
-useParser2 start end = (useParser2' start end) `sepEndBy` newline
-
-useParser2' :: String -> String -> Parser UseDesc
-useParser2' start end =
-      parseComment (useParser2' start end)
-  <|> do { readname <- many1 (satisfy notColon)
-         ; case mid start readname end of
-             LT -> skipMany (satisfy notNewline) >> useParser2' start end
-             GT -> return ("","")
-             otherise -> char ':' >> parseUse
-         }
-
-----------------------------------------------------------------
-
--- In Haskell, vim-core > vim
--- In sort,    vim-core < vim
--- Work around it.
-myCompare :: String -> String -> Ordering
-myCompare [] [] = EQ
-myCompare  _ [] = LT
-myCompare []  _ = GT
-myCompare (a:as) (b:bs) =
-  if r == EQ
-    then myCompare as bs 
-    else r
-  where r = compare a b
-
-mid :: String -> String -> String -> Ordering
-mid l m r
-  | myCompare l m == GT = LT
-  | myCompare m r == GT = GT
-  | otherwise = EQ
-
-----------------------------------------------------------------
-
-parseUse :: Parser UseDesc
-parseUse = do { use <- useFlag
-              ; spaces
-              ; string "- "
-              ; desc <- description
-              ; return (use, desc)
-              }
-
-parseComment :: Parser UseDesc -> Parser UseDesc
-parseComment cont = do { char '#'
-                       ; skipMany (satisfy notNewline)
-                       ; cont
-                       }
-                <|> do { space
-                       ; cont
-                       }
-
-useFlag :: Parser String
-useFlag = many1 (satisfy (/= ' '))
-
-description :: Parser String
-description = many1 (satisfy notNewline)
-
-notColon, notNewline :: Char -> Bool
-notColon ':'    = False
-notColon _      = True
-notNewline '\n' = False
-notNewline _    = True
+-- UseDesc.hs
+--
+-- Module for parsing portageProfile/use.desc and use.local.desc files.
+
+module Adelie.UseDesc (
+  UseDescriptions,
+  readUseDesc,
+  readUseDescPackage
+) where
+
+import Char (isSpace)
+import Data.HashTable as HashTable
+import Monad (when)
+
+import Adelie.ListEx
+import Adelie.Portage
+
+type UseDesc = (String, String)
+type UseDescriptions = HashTable String String
+
+----------------------------------------------------------------
+
+readUseDesc :: IO UseDescriptions
+readUseDesc = do
+  table <- HashTable.new (==) hashString
+  ls <- readFile useDesc
+  mapM_ (useParser table) (lines ls)
+  return table
+
+useParser :: UseDescriptions -> String -> IO ()
+useParser _ ('#':_) = return ()
+useParser table line = insert table use desc
+  where (use, desc) = myBreak line
+
+myBreak :: String -> (String, String)
+myBreak [] = ("", "")
+myBreak (' ':'-':' ':xs) = ("", xs)
+myBreak (x:xs) = (x:ys, zs)
+  where (ys, zs) = myBreak xs
+
+----------------------------------------------------------------
+
+readUseDescPackage :: String -> String -> IO UseDescriptions
+readUseDescPackage start end = do
+  table <- HashTable.new (==) hashString
+  ls <- readFile useDescPackage
+  mapMUntil_ (useParser2 table start end) (lines ls)
+  return table
+
+mapMUntil_ :: Monad m => (a -> m Bool) -> [a] -> m ()
+mapMUntil_ _ [] = return ()
+mapMUntil_ f (x:xs) = do
+  r <- f x
+  when r (mapMUntil_ f xs)
+
+useParser2 :: UseDescriptions -> String -> String -> String -> IO Bool
+useParser2 _ _ _ [] = return True
+useParser2 _ _ _ ('#':_) = return True
+useParser2 table start end str@(c:_) = do
+  case mid start catname end of
+      LT -> return True
+      EQ -> insert table use desc >> return True
+      GT -> return False
+  where str' = reverse $ dropWhile isSpace $ reverse str
+        (catname, rest) = break2 (':' ==) str'
+        (use, desc) = myBreak rest
+  
+----------------------------------------------------------------
+
+-- In Haskell, vim-core > vim
+-- In sort,    vim-core < vim
+-- Work around it.
+myCompare :: String -> String -> Ordering
+myCompare [] [] = EQ
+myCompare  _ [] = LT
+myCompare []  _ = GT
+myCompare (a:as) (b:bs) =
+  if r == EQ
+    then myCompare as bs 
+    else r
+  where r = compare a b
+
+mid :: String -> String -> String -> Ordering
+mid l m r
+  | myCompare l m == GT = LT
+  | myCompare m r == GT = GT
+  | otherwise = EQ
diff --git a/Adelie/opts.c b/Adelie/opts.c
new file mode 100644 (file)
index 0000000..69f5349
--- /dev/null
@@ -0,0 +1,13 @@
+#include "opts.h"
+
+static bool colour = true;
+
+bool colour_enabled(void)
+{
+    return colour;
+}
+
+void set_colour_enabled(const bool on)
+{
+    colour = on;
+}
diff --git a/Adelie/opts.h b/Adelie/opts.h
new file mode 100644 (file)
index 0000000..daa8928
--- /dev/null
@@ -0,0 +1,9 @@
+#ifndef __included_opts_h
+#define __included_opts_h
+
+#include <stdbool.h>
+
+extern bool colour_enabled(void);
+extern void set_colour_enabled(const bool on);
+
+#endif
diff --git a/Main.hs b/Main.hs
old mode 100644 (file)
new mode 100755 (executable)
dissimilarity index 62%
index 7c0a45d..f5f04a8
--- a/Main.hs
+++ b/Main.hs
-#!/usr/bin/runhugs -98
--- Main.hs
---
--- Adelie is a collection of scripts to querying portage packages. 
-
-module Main (main) where
-
-import System
-
-import Adelie.Colour
-import Adelie.QChangelog
-import Adelie.QCheck
-import Adelie.QDepend
-import Adelie.QHasUse
-import Adelie.QList
-import Adelie.QOwn
-import Adelie.QSize
-import Adelie.QUse
-import Adelie.QWant
-
-data Command
-  = Short String String ([String] -> IO ())
-
-logCommands = [
-  (Short "c"  "find the changelog of a package"     qChangelog)
-  ]
-
-listCommands = [
-  (Short "f"  "list the contents of a package"      (qList ListAll)),
-  (Short "fd" "list the directories in a package"   (qList ListDirs)),
-  (Short "ff" "list the files in a package"         (qList ListFiles)),
-  (Short "fl" "list the links in a package"         (qList ListLinks))
-  ]
-
-ownCommands = [
-  (Short "b"  "find the package(s) owning a file"                   qOwn),
-  (Short "bp" "find the package(s) owning a file with regexp"       qOwnRegex),
-  (Short "s"  "find the size of files in a package"                 qSize),
-  (Short "k"  "check MD5sums and timestamps of a package"           qCheck)
-  ]
-
-dependCommands = [
-  (Short "d"  "list packages directly depending on this package"    qDepend),
-  (Short "dd" "list direct dependencies of a package"               qWant)
-  ]
-
-useCommands = [
-  (Short "u"  "describe a package's USE flags"      qUse),
-  (Short "h"  "list all packages with a USE flag"   qHasUse)
-  ]
-
-allCommands =
-  -- All packages
-  logCommands ++ 
-  -- Installed packages only
-  listCommands ++ ownCommands ++ dependCommands ++ useCommands
-
-----------------------------------------------------------------
-
-main :: IO ()
-main = do
-  args <- getArgs
-  case args of
-    [] -> usage
-    (cmd:cargs) -> main' cmd cargs allCommands
-
-main' :: String -> [String] -> [Command] -> IO ()
-main' _ _ [] = usage
-main' command args ((Short cmd _ f):xs)
-  | command == cmd  = f args
-  | otherwise       = main' command args xs
-
-----------------------------------------------------------------
-
-usage :: IO ()
-usage = do
-  putStrLn "Adelie v0.1\n"
-  putStrLn "Usage: adelie <command> <arguments>\n"
-
-  cyan >> putStr "Commands for Installed Packages:" >> off2
-  mapM_ putCommand logCommands; nl
-  mapM_ putCommand listCommands; nl
-  mapM_ putCommand ownCommands; nl
-  mapM_ putCommand dependCommands; nl
-  mapM_ putCommand useCommands; nl
-
-putCommand :: Command -> IO ()
-putCommand (Short cmd desc _) =
-  putStr "    " >> green >> putStr cmd >> off >> tab >> putStrLn desc
-
-tab = putChar '\t'
-nl  = putChar '\n'
+-- Main.hs
+--
+-- Adelie is a collection of scripts to querying portage packages. 
+
+module Main (main) where
+
+import System (getArgs, getProgName)
+
+import Adelie.Colour
+import Adelie.Options
+import Adelie.QChangelog
+import Adelie.QCheck
+import Adelie.QDepend
+import Adelie.QHasUse
+import Adelie.QList
+import Adelie.QOwn
+import Adelie.QSize
+import Adelie.QUse
+import Adelie.QWant
+
+type CommandProc = [String] -> IO ()
+
+data Command
+  = Short String String CommandProc
+  | Long  String String String CommandProc
+
+logCommands = [
+  (Long   "c" "changes"
+          "list changes since the installed version"
+          qChangelog),
+  (Short  "cl"
+          "find the changelog of a package"
+          qLogFile)
+  ]
+
+listCommands = [
+  (Long   "f" "files"
+          "list the contents of a package"
+          (qList ListAll)),
+  (Short  "fd"
+          "list the directories in a package"
+          (qList ListDirs)),
+  (Short  "ff"
+          "list the files in a package"
+          (qList ListFiles)),
+  (Short  "fl"
+          "list the links in a package"
+          (qList ListLinks))
+  ]
+
+ownCommands = [
+  (Long   "b" "belongs"
+          "find the package(s) owning a file"
+          qOwn),
+  (Short  "bp"
+          "find the package(s) owning a file with regexp"
+          qOwnRegex),
+  (Long   "s" "size"
+          "find the size of files in a package"
+          qSize),
+  (Long   "k" "check"
+          "check MD5sums and timestamps of a package"
+          qCheck)
+  ]
+
+dependCommands = [
+  (Long   "d" "depends"
+          "list packages directly depending on this package"
+          qDepend),
+  (Short  "dd"
+          "list direct dependencies of a package"
+          qWant)
+  ]
+
+useCommands = [
+  (Long   "u" "uses"
+          "describe a package's USE flags"
+          qUse),
+  (Long   "h" "hasuse"
+          "list all packages with a USE flag"
+          qHasUse)
+  ]
+
+allCommands = logCommands ++ listCommands ++ ownCommands ++ dependCommands ++ useCommands
+
+----------------------------------------------------------------
+
+main :: IO ()
+main = do
+  args0 <- getArgs
+  let (options, commands) = span isOption args0
+  mapM_ parseOptions options
+  case commands of
+    [] -> usage
+    (cmd:cargs) -> (runCommand cmd allCommands) cargs
+
+
+isOption :: String -> Bool
+isOption = ('-' ==) . head
+
+----------------------------------------------------------------
+
+parseOptions :: String -> IO ()
+parseOptions [] = return ()
+
+parseOptions "-C"         = setColourEnabled False
+parseOptions "--nocolor"  = setColourEnabled False
+parseOptions "--nocolour" = setColourEnabled False
+
+parseOptions _ = return ()
+
+----------------------------------------------------------------
+
+runCommand :: String -> [Command] -> CommandProc
+runCommand _ [] = (\ _ -> usage)
+
+runCommand command ((Short cmd _ f):cs)
+  | command == cmd  = f
+  | otherwise       = runCommand command cs
+
+runCommand command ((Long cmd0 cmd1 _ f):cs)
+  | command == cmd0 = f
+  | command == cmd1 = f
+  | otherwise       = runCommand command cs
+
+----------------------------------------------------------------
+
+usage :: IO ()
+usage = do
+  prog <- getProgName
+  putStrLn "fquery 0.2\n"
+  putStrLn $ "Usage: " ++ prog ++ " [options] <command> <arguments>\n"
+
+  cyan >> putStr "Options:" >> off2
+  inYellow (putStr "    -C --nocolour") >> tab >> putStrLn "turn off colours"
+  nl
+
+  cyan >> putStr "Commands for Installed Packages:" >> off2
+  mapM_ putCommand logCommands; nl
+  mapM_ putCommand listCommands; nl
+  mapM_ putCommand ownCommands; nl
+  mapM_ putCommand dependCommands; nl
+  mapM_ putCommand useCommands; nl
+
+putCommand :: Command -> IO ()
+putCommand (Short cmd desc _) = f `withDesc` desc
+  where f = green >> putStr cmd >> off >> tab
+
+putCommand (Long cmd0 cmd1 desc _) = f `withDesc` desc
+  where f = green >> putStr (cmd0 ++ "  " ++ cmd1) >> off
+
+withDesc :: IO () -> String -> IO ()
+f `withDesc` desc = putStr "    " >> f >> tab >> putStrLn desc
+
+tab = putChar '\t'
+nl  = putChar '\n'
diff --git a/Makefile b/Makefile
deleted file mode 100644 (file)
index e8e12a2..0000000
--- a/Makefile
+++ /dev/null
@@ -1,13 +0,0 @@
-HC  := ghc
-HCFLAGS := -O -odirobj -package text -fglasgow-exts
-PROG := adelie
-
-all : $(PROG)
-
-.PHONY: adelie
-adelie : Main.hs
-       $(HC) $(HCFLAGS) --make -o $@ $<
-
-.PHONY : strip
-strip :
-       strip $(PROG)
diff --git a/Setup.hs b/Setup.hs
new file mode 100755 (executable)
index 0000000..656d14b
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+import Distribution.Simple
+main = defaultMainWithHooks defaultUserHooks
diff --git a/configure b/configure
new file mode 100755 (executable)
index 0000000..a48b69b
--- /dev/null
+++ b/configure
@@ -0,0 +1,23 @@
+#!/bin/sh
+#
+# Fake configure script.
+
+portageq=/usr/bin/portageq
+
+PORTAGE_TREE=`${portageq} portdir 2>/dev/null`
+PORTAGE_DB=`${portageq} vdb_path 2>/dev/null`
+
+if [ -z $PORTAGE_TREE ]; then
+  PORTAGE_TREE="/usr/portage"
+fi
+
+if [ -z $PORTAGE_DB ]; then
+  PORTAGE_DB="/var/db/pkg"
+fi
+
+echo "portdir: ${PORTAGE_TREE}"
+echo "vdb_path: ${PORTAGE_DB}"
+
+sed -e s,'@@PortageTree@@',"\"${PORTAGE_TREE}\"",      \
+    -e s,'@@PortageDB@@',"\"${PORTAGE_DB}\"",          \
+    "Adelie/Config.hs.in" > "Adelie/Config.hs"
diff --git a/fquery.cabal b/fquery.cabal
new file mode 100644 (file)
index 0000000..796c10c
--- /dev/null
@@ -0,0 +1,38 @@
+Name:          fquery
+Version:       0.2
+Author:                David Wang <millimillenary@gmail.com>
+Maintainer:    David Wang <millimillenary@gmail.com>
+Copyright:     2006 David Wang
+License-File:  LICENCE.txt
+License:       OtherLicense
+Synopsis:      Installed package query tool for Gentoo Linux
+Build-depends: base, haskell98, parsec, unix
+Extra-Source-Files:
+                configure
+               Adelie/Config.hs.in
+               Adelie/opts.h
+
+Executable:    fquery
+Main-is:       Main.hs
+Other-Modules: Adelie.Colour
+               Adelie.CompareVersion
+               Adelie.Contents
+               Adelie.Depend
+               Adelie.ListEx
+                Adelie.Options
+               Adelie.Portage
+               Adelie.Pretty
+               Adelie.Provide
+               Adelie.QChangelog
+               Adelie.QCheck
+               Adelie.QDepend
+               Adelie.QHasUse
+               Adelie.QList
+               Adelie.QOwn
+               Adelie.QSize
+               Adelie.QUse
+               Adelie.QWant
+               Adelie.Use
+               Adelie.UseDesc
+GHC-Options:   -O
+c-sources:     Adelie/opts.c