Adelie/QOwn.hs

   1 -- QOwn.hs
   2 --
   3 -- Module to query who owns a particular file.
   4
   5 module Adelie.QOwn (
   6   qOwn,
   7   qOwnRegex
   8 ) where
   9
  10 import List       (delete)
  11 import Monad      (when)
  12 import Text.Regex (Regex, matchRegex, mkRegex)
  13
  14 import Adelie.Contents
  15 import Adelie.ListEx
  16 import Adelie.Portage
  17 import Adelie.Pretty
  18
  19 ----------------------------------------------------------------
  20
  21 qOwn :: [String] -> IO ()
  22 qOwn [] = return ()
  23 qOwn args = do
  24   foldMUntil qOwn' null args =<< allInstalledPackages
  25   putChar '\n'
  26
  27 qOwn' :: [String] -> (String, String) -> IO [String]
  28 qOwn' files catname = readContents (puts catname) contents files
  29   where contents = contentsFromCatName catname
  30
  31 ----------------------------------------------------------------
  32
  33 puts :: (String, String) -> Contents -> [String] -> IO (Bool, [String])
  34 puts catname c fs =
  35   if c `contentsElem` fs
  36     then do
  37       let fs' = deleteContent c fs
  38       putCatName catname >> putStr " (" >> putContents c >> putStrLn ")"
  39       return (null fs', fs')
  40     else
  41       return (False, fs)
  42
  43 contentsElem :: Contents -> [String] -> Bool
  44 (Dir d)     `contentsElem` fs = d `elem` fs
  45 (Obj o _ _) `contentsElem` fs = o `elem` fs
  46 (Sym l _ _) `contentsElem` fs = l `elem` fs
  47
  48 -- Only remove objects from the list.
  49 deleteContent :: Contents -> [String] -> [String]
  50 deleteContent (Obj o _ _) fs = delete o fs
  51 deleteContent _ fs = fs
  52
  53 ----------------------------------------------------------------
  54
  55 qOwnRegex :: [String] -> IO ()
  56 qOwnRegex args = mapM_ (qOwnRegex' pats) =<< allInstalledPackages
  57   where pats = map mkRegex args
  58
  59 qOwnRegex' :: [Regex] -> (String, String) -> IO ()
  60 qOwnRegex' pats catname = readContents (putsRegex catname pats) contents ()
  61   where contents = contentsFromCatName catname
  62
  63 putsRegex :: (String, String) -> [Regex] -> Contents -> () -> IO (Bool, ())
  64 putsRegex catname pats c _ = do
  65   when (c `regexElem` pats) match
  66   return (False, ())
  67   where match = putCatName catname >> putStr " (" >> putContents c>>putStrLn ")"
  68
  69 regexElem :: Contents -> [Regex] -> Bool
  70 (Dir d)     `regexElem` pats = mapMaybeOnce (flip matchRegex d) pats
  71 (Obj o _ _) `regexElem` pats = mapMaybeOnce (flip matchRegex o) pats
  72 (Sym l _ _) `regexElem` pats = mapMaybeOnce (flip matchRegex l) pats
  73
  74 mapMaybeOnce :: (a -> Maybe b) -> [a] -> Bool
  75 mapMaybeOnce _ [] = False
  76 mapMaybeOnce f (x:xs) =
  77   case f x of
  78     Just _a  -> True
  79     Nothing -> mapMaybeOnce f xs