packages feed

xmonad-extras 0.9 → 0.9.1

raw patch · 9 files changed

+720/−55 lines, 9 filesdep +HListdep +template-haskelldep ~basedep ~hintdep ~libmpdnew-uploader

Dependencies added: HList, template-haskell

Dependency ranges changed: base, hint, libmpd, parsec, split, xmonad, xmonad-contrib

Files

XMonad/Actions/Eval.hs view
@@ -28,7 +28,6 @@ import XMonad.Core import XMonad.Util.Run import Language.Haskell.Interpreter-import Control.Monad import Data.List  -- $usage
XMonad/Actions/Volume.hs view
@@ -9,7 +9,7 @@ -- Stability    : unstable -- Portability  : unportable ----- A minimal interface to the "amixer" command-line utility.+-- A minimal interface to the \"amixer\" command-line utility. -- ---------------------------------------------------------------------------- module XMonad.Actions.Volume (@@ -244,7 +244,7 @@ sepBy' p sep = liftM2 (:) p loop where     loop = (sep >> (liftM2 (:) p loop <|> return [])) <|> return [] --- | Helper function to output current volume via osd_cat.(Needs the osd_cat executable).+-- | Helper function to output current volume via osd_cat.  (Needs the osd_cat executable). -- The second parameter is passed True when the speakers are muted and should -- return the options to pass to osd_cat. osdCat :: MonadIO m => Double -> (Bool -> String) -> m ()
+ XMonad/Config/Alt.hs view
@@ -0,0 +1,38 @@+{- |++Module      :  XMonad.Config.Alt+Copyright   :  Adam Vogt <vogt.adam@gmail.com>+License     :  BSD3-style (see LICENSE)++Maintainer  :  Adam Vogt <vogt.adam@gmail.com>+Stability   :  unstable+Portability :  unportable++Alternative, more composable config.++This means the config can be assembled using pieces that encode:++ * correct composition when config options don't commute: @a (b conf)@ works, but @b (a (conf)@ is nonsense (ex. respecting layout hints and other layout modifiers).++ * features that must be enabled once-only++ * bundling multiple features in a single function: 'Config' captures IO++ * collect warnings (nothing uses this feature yet)+++For examples, refer to sources:++ * "XMonad.Config.Alt.Sample"++Implementation++ * "XMonad.Config.Alt.Internal"++-}+module XMonad.Config.Alt (+  module XMonad.Config.Alt.Desktop,+  module XMonad.Config.Alt.Internal) where++import XMonad.Config.Alt.Internal+import XMonad.Config.Alt.Desktop
+ XMonad/Config/Alt/Desktop.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++{- |+Module      :  XMonad.Config.Alt.Desktop+Copyright   :  Adam Vogt <vogt.adam@gmail.com>+License     :  BSD3-style (see LICENSE)++Maintainer  :  Adam Vogt <vogt.adam@gmail.com>+Stability   :  unstable+Portability :  unportable++Adapts functionality from some contrib modules++-}+module XMonad.Config.Alt.Desktop (++  -- * "XMonad.Hooks.DynamicLog"+  dzen,+  xmobar,+  statusBar,++  -- * "XMonad.Hooks.EwmhDesktops"+  ewmh,++  -- * "XMonad.Hooks.ManageDocks"+  avoidStrutsOn,+  avoidStruts,++  ) where++import qualified XMonad as X+import qualified XMonad.Hooks.EwmhDesktops as E+import qualified XMonad.Hooks.ManageDocks as ManageDocks+import qualified XMonad.Hooks.DynamicLog as DynamicLog+import XMonad.Config.Alt.Internal+import Control.Monad.Trans++$(decNat "avoidStrutsPrec" 1)+$(decNat "statusBarPrec" 2)+$(decNat "ewmhPrec" 6)++-- | See 'E.ewmh'+ewmh c = ins' ewmhPrec hTrue (liftM E.ewmh) c++-- | See 'ManageDocks.avoidStrutsOn'+avoidStrutsOn a c = ins' avoidStrutsPrec hTrue+                  (m Modify LayoutHook (ManageDocks.avoidStrutsOn a) =<<)+                  c+++-- | See 'ManageDocks.avoidStruts'+avoidStruts c = ins' avoidStrutsPrec hTrue+              (m Modify LayoutHook ManageDocks.avoidStruts =<<)+              c++-- | See 'DynamicLog.statusBar'+statusBar cmd pp k conf = avoidStruts . ins' statusBarPrec hTrue +                           (\c -> do+                               c' <- c+                               c'' <- liftIO $ DynamicLog.statusBar cmd pp k c'+                               return $ c'' { X.layoutHook = X.layoutHook c' }+                           )+                         $ conf++toggleStrutsKey c = (X.modMask c, X.xK_b)+                                                                   +xmobar conf = statusBar+              "xmobar" +              DynamicLog.xmobarPP +              toggleStrutsKey +              conf+                                                       +dzen conf = statusBar+              ("dzen2" ++ flags)+              DynamicLog.xmobarPP +              toggleStrutsKey +              conf+ where+    fg      = "'#a8a3f7'" -- n.b quoting+    bg      = "'#3f3c6d'"+    flags   = "-e 'onstart=lower' -w 400 -ta l -fg " ++ fg ++ " -bg " ++ bg
+ XMonad/Config/Alt/Internal.hs view
@@ -0,0 +1,443 @@+{-# LANGUAGE+    OverlappingInstances+    ,EmptyDataDecls+    ,FlexibleContexts+    ,FlexibleInstances+    ,FunctionalDependencies+    ,GeneralizedNewtypeDeriving+    ,KindSignatures+    ,MultiParamTypeClasses+    ,NoMonomorphismRestriction+    ,ScopedTypeVariables+    ,TemplateHaskell+    ,TypeOperators+    ,TypeSynonymInstances+    ,UndecidableInstances+    ,ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+-- I can't figure out an acceptable type for 'set' and similar:+-- ghc doesn't accept the type inferred by ghci++{- |++Module      :  XMonad.Config.Alt.Internal+Copyright   :  Adam Vogt <vogt.adam@gmail.com>+License     :  BSD3-style (see LICENSE)++Maintainer  :  Adam Vogt <vogt.adam@gmail.com>+Stability   :  unstable+Portability :  unportable++Import "XMonad.Config.Alt".+-}+module XMonad.Config.Alt.Internal (+    module XMonad.Config.Alt.QQ,++    -- * Running+    runConfig,+    runConfig',++    -- * Actions+    -- $actions+    set,+    add,+    modify,+    modifyIO,++    -- ** less useful+    modifyIO',+    insertInto,++    -- * Things to modify+    -- ** Special+    LayoutHook(LayoutHook),++    -- ** Others+    FocusFollowsMouse(FocusFollowsMouse),+    StartupHook(StartupHook),+    LogHook(LogHook),+    BorderWidth(BorderWidth),+    MouseBindings(MouseBindings),+    Keys(Keys),+    ModMask(ModMask),+    Workspaces(Workspaces),+    HandleEventHook(HandleEventHook),+    ManageHook(ManageHook),+    Terminal(Terminal),+    FocusedBorderColor(FocusedBorderColor),+    NormalBorderColor(NormalBorderColor),++    -- * Relatively private+    -- | You probably don't need these+    defaultPrec,++    -- ** Ordered Insertion into HLists like [(Nat,a)]+    insLt,+    insGeq,+    Ins2(..),+    Ins'(..),+    ins,++    -- ** Useful functions+    HCompose(hComp),+    Snd(Snd),+    HSubtract(hSubtract),+    HReplicateF(hReplicateF),+    HPred'(hPred'),++    -- ** For overloading+    Mode(..),+    Add(Add),+    Set(Set),+    Modify(Modify),+    ModifyIO(ModifyIO),++    Config(..),++    test,++    module Data.HList,+ ) where++import Control.Monad.Writer+import Data.Char+import Data.HList+import Language.Haskell.TH++import qualified XMonad as X+import XMonad.Config.Alt.Types+import XMonad.Config.Alt.QQ++-- * Class to write set / modify as functions+class Mode action field e x y | action field e x -> y, action field x y -> e where+    m :: action -> field -> e -> X.XConfig x -> Config (X.XConfig y)++-- * Actions for 'Mode'+data Add = Add -- ^ the 'Mode' instance combines the old value like  @new `mappend` old@+data Set = Set+data Modify = Modify+data ModifyIO = ModifyIO++$(decNat "defaultPrec" 4)++{- $actions++Use 'set', 'add', 'modify', 'modifyIO' for most predefined fields in 'XConfig'.++For constructing things to modify a config:++> insertInto action hold prec field v++ * @action@  is an instance of 'Mode' so you only need to write 'ModifyIO' to describe how to access this field.++ * @hold@    is 'HTrue' if you don't want to overwrite a preexisting value at the same @prec@. This is for things that should be applied once-only.++ * @field@   used with the 'Mode'++ * @v@       the value that is being updated (or a function if you use 'Modify' or similar)++-}+set f v = insertInto Set hFalse defaultPrec f v+add f v = insertInto Add hFalse defaultPrec f v+modify f v = insertInto Modify hFalse defaultPrec f v+modifyIO = modifyIO' hFalse defaultPrec++modifyIO' x = insertInto ModifyIO x++insertInto action hold prec f x = ins' prec hold (m action f x =<<)++-- | Represent setting layouts and layout modifiers+data LayoutHook = LayoutHook+++instance Mode ModifyIO LayoutHook (l X.Window -> Config (m X.Window)) l m where+    m _ _ l c = do+        l' <- l $ X.layoutHook c+        return $ c { X.layoutHook = l' }++-- | 'Add' means something else for 'X.layoutHook' because there's no suitable+-- mempty for the general instance of 'X.LayoutClass'+instance (X.LayoutClass l X.Window, X.LayoutClass l' X.Window) =>+        Mode Add LayoutHook (l' X.Window) l (X.Choose l' l) where+    m _ _ l = \x -> return $ x { X.layoutHook = l X.||| X.layoutHook x }++instance (Read (l X.Window), X.LayoutClass l X.Window,+          Read (l' X.Window), X.LayoutClass l' X.Window) =>+        Mode Modify LayoutHook (l X.Window -> l' X.Window) l l' where+    m _ _ l = \x -> return $ x { X.layoutHook = l (X.layoutHook x) }++instance (X.LayoutClass l' X.Window) =>+        Mode Set LayoutHook (l' X.Window) l l' where+    m _ _ l = \x -> return $ x { X.layoutHook = l }+++++++data Snd = Snd+instance Apply Snd (a, b) b where+    apply _ (_, b) = b+++-- | like  @foldr (.) id@, but for a heteregenous list.+class HCompose l f | l -> f where+    hComp :: l -> f++instance HCompose HNil (a -> a) where+    hComp _ = id++instance HCompose r (a -> b) => HCompose ((b -> c) :*: r) (a -> c) where+    hComp (HCons g r) = g . hComp r++++-- | The difference between HNats. Clamped to HZero+class HSubtract a b c | a b -> c where+    hSubtract :: a -> b -> c++instance (HNat a, HNat b, HSubtract a b c) => HSubtract (HSucc a) (HSucc b) c where+    hSubtract a b = hSubtract (hPred a) (hPred b)++instance HNat a => HSubtract a HZero a where+    hSubtract a _ = a++instance HSubtract HZero b HZero where+    hSubtract _ _ = hZero+++class HNat n => HReplicateF n e l | n e -> l where+    hReplicateF :: n -> e -> l++instance HReplicateF HZero e HNil where+    hReplicateF _ _ = HNil++instance (Apply e x y, HReplicateF n e r) => HReplicateF (HSucc n) e ((HFalse, x -> y) :*: r) where+    hReplicateF n e = (hFalse, apply e) `HCons` hReplicateF (hPred n) e++++-- | exactly like hPred, but accept HZero too+class HPred' n n' | n -> n' where+    hPred' :: n -> n'++instance HPred' HZero HZero where+    hPred' _ = hZero++instance HNat n => HPred' (HSucc n) n where+    hPred' = hPred++insLt n hold f l =+    l+     `hAppend`+    (hReplicateF ({-hPred' $ -} n `hSubtract` hLength l) Id)+     `hAppend`+    ((hold,f) `HCons` HNil)++insGeq n a f l =+    let (b,g) = hLookupByHNat n l+        h = hCond b (b,g) (a,f . g)+    in hUpdateAtHNat n h l++-- | utility class, so that we can use contexts that may not be satisfied,+-- depending on the length of the accumulated list.+class (HBool hold) => Ins2 b n hold f l l' | b n hold f l -> l' where+    ins2 :: b -> n -> hold -> f -> l -> l'++-- | when l needs to be padded with id+instance+     (-- HPred' a n',+      HLength l n,+      HSubtract a1 n a,+      -- HReplicateF n' Id l',+      HReplicateF a Id l',+      HAppend l l' l'',+      HAppend l'' (HCons (hold,e) HNil) l''1,+      HBool hold) =>+  Ins2 HTrue a1 hold e l l''1+ where ins2 _ = insLt++-- | when l already has enough elements, just compose. Only when the existing HBool is HFalse+instance+     (HLookupByHNat n l (t, a -> b),+      HUpdateAtHNat n z l l',+      HCond t (t, a -> b) (t1, a -> c) z,+      HBool t1) =>+  Ins2 HFalse n t1 (b -> c) l l'+ where ins2 _ = insGeq++class Ins' n hold f l l' | n hold f l -> l' where+    ins' :: n -> hold -> f -> l -> l'++instance (HLength l ll, HLt ll n b,  Ins2 b n hold f l l') => Ins' n hold f l l' where+    ins' = ins2 (undefined :: b)++{- | @ins n f xs@ inserts at index @n@ the function f, or extends the list @xs@+with 'id' if there are too few elements. This way the precedence is not+bounded.+-}+ins n e = ins' n hFalse (e =<<)++runConfig' defConfig x = do+    let Config c = hComp (hMap Snd (hComp (hEnd x) HNil)) (return defConfig)+    (a,w) <- runWriterT c+    print (w [])+    return a++--runConfig :: (X.LayoutClass l X.Window, Read (l X.Window)) => Config (X.XConfig l) -> IO ()+runConfig x = X.xmonad =<< runConfig' X.defaultConfig x++-- * Tests++data T1 a = T1 a deriving Show+data T2 a = T2 a deriving Show+data T3 a = T3 a deriving Show+data T3a a = T3a a deriving Show++data RunMWR = RunMWR+instance (Monad m, HCompose l (m () -> Writer w a)) => Apply RunMWR l (a, w) where+    apply _ x = runWriter $ hComp x (return ())+data Print = Print+instance Show a => Apply Print a (IO ()) where+    apply _ = print++data HHMap a = HHMap a+instance HMap f a b => Apply (HHMap f) a b where+    apply (HHMap f) = hMap f++{- | Verification that insertions happen in order++> (T1 (),"3")+> (T2 (T1 ()),"31")+> (T2 (T3 (T1 ())),"321")+> (T2 (T3a (T3 (T1 ()))),"3221")++-}+test :: IO ()+test = sequence_ $ hMapM Print $ hMap RunMWR $ hMap (HHMap Snd) $ hEnd $ hBuild+    test1_+    test2_+    test3_+    test3a_+  where+    test1_ = ins (undefined `asTypeOf` hSucc (hSucc (hSucc hZero))) (\x -> tell "3" >> return (T1 x)) hNil+    test2_ = ins (hSucc hZero) (\x -> tell "1" >> return (T2 x)) test1_+    test3_ = ins (hSucc (hSucc hZero)) (\x -> tell "2" >> return (T3 x)) test2_+    test3a_ = ins (hSucc (hSucc hZero)) (\x -> tell "2" >> return (T3a x)) test3_+++{- Generated instances for monomorphic fields in 'X.XConfig'++Follows the style of:++> data FFM = FFM++> instance Mode ModifyIO FFM (Bool -> Config Bool) l l where+>     m _ _ f c = do+>         r <- f (X.fFM c)+>         return $ c { X.fFM = r }++And the same for Modify, Set++> instance (Fail (Expected String)) => Mode ModifyIO FFM y z w where+> instance (Fail (Expected String)) => Mode Modify FFM y z w where+> instance (Fail (Expected String)) => Mode Set FFM y z w where++The last set of overlapping instances exist to help type inference here:++> :t m ModifyIO NormalBorderColor+> m ModifyIO NormalBorderColor+>   :: (String -> Config String) -> XConfig x -> Config (XConfig x)++Otherwise it would just give you:++> m ModifyIO NormalBorderColor+>      :: Mode ModifyIO NormalBorderColor e x y =>+>          e -> XConfig x -> Config (XConfig y)++Which doesn't really matter overall since @x@ ends up fixed when you try+to run the config.++-}++-- | Improve error messages maybe.+data Expected a++$(fmap concat $ sequence+   [ do+        -- do better by using quoted names in the first place?+     let accessor = "X." ++ (case nameBase d of+                                x:xs -> toLower x:xs+                                _ -> [])+         acc = mkName accessor+     VarI _ (ForallT _ _ (_ `AppT` (return -> ty))) _ _ <- reify acc+     l <- fmap varT $ newName "l"++     let mkId action tyIn body = instanceD+                (return [])+                [t| $(conT ''Mode) $(conT action) $(conT d) $(tyIn) $l $l |]+                [funD 'm+                    [clause+                        [wildP,wildP]+                        (normalB body+                            )+                        []+                    ]+                ]+            `const` (action, tyIn) -- suppress unused var warning++     let fallback act = instanceD+            (sequence [classP ''Fail [[t| Expected $ty |]]])+            [t| $(conT ''Mode) $act $(conT d) $(varT =<< newName "x") $l $l |]+            [funD 'm [clause [] (normalB [| error "impossible to satisfy" |]) [] ]]+          `const` act              -- suppress unused var warning++     sequence $++      [fallback (conT n) | n <- [''ModifyIO, ''Modify, ''Set] ] ++++      [dataD (return []) d [] [normalC d []] []++      ,mkId ''ModifyIO [t| $ty -> Config $ty |]+                        [| \f c -> do+                                r <- f ($(varE acc) c)+                                return $(recUpdE+                                            [| c |]+                                            [fmap (\r' -> (acc,r')) [| r |]])+                                |]++      ,mkId ''Modify   [t| $ty -> $ty |]+                        [| \f c -> do+                                r <- return $ f ($(varE acc) c)+                                return $(recUpdE+                                            [| c |]+                                            [fmap (\r' -> (acc,r')) [| r |]])+                                |]++      ,mkId ''Set      [t| $ty |]+                        [| \f c -> do+                                return $(recUpdE+                                            [| c |]+                                            [fmap ((,) acc) [| f |]])+                                |]+      ]++    | d <- map mkName+           -- fields in XConf+           -- XXX make these ' versions so we can be hygenic+           ["NormalBorderColor",+            "FocusedBorderColor",+            "Terminal",+            -- "LayoutHook", -- types $l and $l change with updates+            "ManageHook",+            "HandleEventHook",+            "Workspaces",+            "ModMask",+            "Keys",+            "MouseBindings",+            "BorderWidth",+            "LogHook",+            "StartupHook",+            "FocusFollowsMouse"]+    ]+ )
+ XMonad/Config/Alt/QQ.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TemplateHaskell #-}++{- | Shorthand. The following are equivalent:++> hSucc (hSucc hZero)++> [$nat'| 2 |]++> $(nat 2)++-}+module XMonad.Config.Alt.QQ where++import Language.Haskell.TH.Quote+import Language.Haskell.TH+import Data.HList+++nat' :: QuasiQuoter+nat' = QuasiQuoter { quoteExp = \n -> nat (read n),+                     quotePat = error "XMonad.Config.Alt.QQ.nat'.quotePat: unimplemented"}++nat :: Int -> ExpQ+nat n = foldr appE [| hZero |] (replicate n [| hSucc |])++natTy :: Int -> TypeQ+natTy n = foldr appT [t| HZero |] (replicate n [t| HSucc |])++decNat :: String -> Int -> Q [Dec]+decNat t n = do+  d <- valD (varP (mkName t)) (normalB (nat n)) []+  s <- sigD (mkName t) (natTy n)+  return [s,d]
+ XMonad/Config/Alt/Sample.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module XMonad.Config.Alt.Sample where+import XMonad.Config.Alt as C+import XMonad+import qualified XMonad.Hooks.ManageDocks+import qualified XMonad.Hooks.DynamicLog++ex1, ex2 :: IO ()+ex1 = runConfig $ hBuild+    (C.modify Workspaces (++["lol","hi"]))+    (C.set ModMask mod4Mask)+    (C.modify LayoutHook XMonad.Hooks.ManageDocks.avoidStruts)++ex2 = runConfig ex2'++ex2' = hEnd $ hBuild+      (C.avoidStruts)+      (C.statusBar "xmobar" XMonad.Hooks.DynamicLog.xmobarPP (\c -> (modMask c, xK_b)))+      (C.set LayoutHook (Tall 2 0.5 0.02))++ex2'' = runConfig' defaultConfig ex2'
XMonad/Prompt/MPD.hs view
@@ -1,22 +1,21 @@-{-# LANGUAGE PatternGuards, Rank2Types #-}+{-# LANGUAGE Rank2Types #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.MPD--- Copyright   :  Daniel Schoepe <daniel.schoepe@gmail.com>+-- Copyright   :  Daniel Schoepe <daniel.schoepe@googlemail.com> -- License     :  BSD3-style (see LICENSE) ----- Maintainer  :  Daniel Schoepe <daniel.schoepe@gmail.com>+-- Maintainer  :  Daniel Schoepe <daniel.schoepe@googlemail.com> -- Stability   :  unstable -- Portability :  unportable ----- This module lets you select songs and add/play songs with MPD by filtering--- them by user-supplied criteria(E.g. ask for an artist, then for the album..)+-- This module lets the user select songs and have MPD add/play them by+-- filtering them by user-supplied criteria(E.g. ask for an artist, then for+-- the album..) -- ----------------------------------------------------------------------------- --- TODO: Add other backends besides mpd(e.g. amarok via dcop).- module XMonad.Prompt.MPD (-- * Usage                           -- $usage                           findMatching@@ -26,16 +25,14 @@                          ,findOrAdd                          )  where import Control.Monad-import Control.Applicative import Data.Char+import qualified Data.Map as M+import Data.Maybe import Network.MPD-import System.IO import XMonad import XMonad.Prompt-import XMonad.Prompt.Input import Data.List (nub,isPrefixOf,findIndex) - -- $usage -- -- To use this, import the following modules:@@ -43,52 +40,80 @@ -- > import XMonad.Prompt.MPD -- > import qualified Network.MPD as MPD ----- You can then use this in a keybinding, to filter first by artist, then by album and add --- the matching songs:--- --- > addMatching MPD.withMPD defaultXPConfig [MPD.sgArtist, MPD.sgAlbum] >> return ()+-- You can then use this in a keybinding, to filter first by artist, then by+-- album and add the matching songs: ----- If you need a password to connect to your MPD or need a different host/port, you can pass a--- partially applied withMPDEx to the function:+-- > addMatching MPD.withMPD defaultXPConfig [MPD.Artist, MPD.Album] >> return () ----- > addMatching (MPD.withMPDEx "your.host" 666 (return $ Just $ "password")) ..+-- That way you will first be asked for an artist name, then for an album by+-- that artist etc.. --+-- If you need a password to connect to your MPD or need a different host/port,+-- you can pass a partially applied withMPDEx to the function:+--+-- > addMatching (MPD.withMPDEx "your.host" 4242 "very secret") ..+-- --- | Allows the user to supply a custom way to connect to MPD (e.g. partially applied withMPDEx).+-- | Allows the user to supply a custom way to connect to MPD (e.g. partially+-- applied withMPDEx). type RunMPD = forall a . MPD a -> IO (Response a) +-- | A new prompt type since Prompt.Input causes problems when completing+-- strings with spaces in them+data MPDPrompt = MPDPrompt String++instance XPrompt MPDPrompt where+    showXPrompt (MPDPrompt s) = s ++ ": "+    nextCompletion = const getNextCompletion+    commandToComplete = const id++-- | Extracts the given metadata attribute from a Song+extractMetadata :: Metadata -> Song -> String+extractMetadata meta = fromMaybe "Unknown" . join . fmap listToMaybe .+                       M.lookup meta . sgTags+ -- | Creates a case-insensitive completion function from a list. mkComplLst :: [String] -> String -> IO [String]-mkComplLst lst s = return . filter (\s' -> map toLower s `isPrefixOf` map toLower s') $ lst+mkComplLst lst s = return . filter isPrefix' $ lst+    where isPrefix' s' = map toLower s `isPrefixOf` map toLower s' -findMatching' :: XPConfig -> [Song] -> (Song -> String) -> X [Song]-findMatching' xp s m = do-  Just input <- inputPromptWithCompl xp "MPD" (mkComplLst . nub . map m $ s)-  return $ filter ((==input) . m) s+-- | Helper function for 'findMatching'+findMatching' :: XPConfig -> [Song] -> Metadata -> X [Song]+findMatching' _ [] _ = return []+findMatching' xp songs meta = do+  answer <- mkXPromptWithReturn (MPDPrompt (show meta)) xp+           (mkComplLst . nub . map (extractMetadata meta) $ songs)+           return+  case answer of+    Just input -> return $ filter ((==input) . extractMetadata meta) songs+    Nothing -> return [] --- | Lets the user filter out non-matching with a prompt by supplied criteria.-findMatching :: RunMPD -> XPConfig -> [Song -> String] -> X [Song]-findMatching runMPD xp ms = do-  -- rs <- io (runMPD $ rights `fmap` listAllInfo "")-  -- workaround due to a bug in libmpd(reported and fixed in darcs).-  -- should be replaced by the line above when a new version is released.-  -- (last version with this bug: 0.3.1)-  rs <- io . runMPD . fmap concat $ mapM findArtist =<< listArtists-  case rs of-    Left e -> io (hPutStrLn stderr $ "MPD error: " ++ show e)  >> return []-    Right s -> foldM (findMatching' xp) s ms+-- | Lets the user filter out non-matching songs. For example, if given+-- [Artist, Album] as third argument, this will prompt the user for an+-- artist(with tab-completion), then for an album by that artist and then+-- returns the songs from that album.+findMatching :: RunMPD -> XPConfig -> [Metadata] -> X [Song]+findMatching runMPD xp metas = do+  resp <- io . runMPD . listAllInfo $ ""+  case resp of+    Left err -> trace ("XMonad.Prompt.MPD: MPD returned an error: " ++ show err)+                >> return []+    Right songs -> foldM (findMatching' xp) songs metas  -- | Determine playlist position of the song and add it, if it isn't present.-findOrAdd :: Song -> MPD PLIndex-findOrAdd s = playlistInfo Nothing >>= \pl -> do+findOrAdd :: Song -> MPD Int+findOrAdd s = playlistInfo Nothing >>= \pl ->   case findIndex ((== sgFilePath s) . sgFilePath) pl of-    Just i -> return . Pos . fromIntegral $ i-    Nothing -> ID <$> (addId . sgFilePath $ s)+    Just i -> return . fromIntegral $ i+    Nothing -> flip addId Nothing . sgFilePath $ s --- | Add all selected songs to the playlist if they are not on it.-addMatching :: RunMPD -> XPConfig -> [Song -> String] -> X [PLIndex]-addMatching r xp ms = findMatching r xp ms >>= fmap (either (const []) id) . io . r . mapM findOrAdd+-- | Add all selected songs to the playlist if they are not in it.+addMatching :: RunMPD -> XPConfig -> [Metadata] -> X [Int]+addMatching runMPD xp metas = do+  matches <- findMatching runMPD xp metas+  fmap (either (const []) id) . io . runMPD . mapM findOrAdd $ matches  -- | Add matching songs and play the first one.-addAndPlay :: RunMPD -> XPConfig -> [Song -> String] -> X ()-addAndPlay r xp ms = addMatching r xp ms >>= io . r . play . Just . head >> return ()+addAndPlay :: RunMPD -> XPConfig -> [Metadata] -> X ()+addAndPlay runMPD xp ms = addMatching runMPD xp ms >>=+                          io . runMPD . play . listToMaybe >> return ()
xmonad-extras.cabal view
@@ -1,12 +1,14 @@ name:               xmonad-extras-version:            0.9+version:            0.9.1 homepage:           http://projects.haskell.org/xmonad-extras synopsis:           Third party extensions for xmonad with wacky dependencies+description:        Various modules for xmonad that cannot be added to xmonad-contrib+                    because of additional dependencies. category:           System license:            BSD3 license-file:       LICENSE author:             The Daniels Schoepe and Wagner-maintainer:         daniel@wagner-home.com, daniel.schoepe@gmail.com+maintainer:         daniel@wagner-home.com, daniel.schoepe@googlemail.com cabal-version:      >= 1.2.1 build-type:         Simple @@ -25,19 +27,27 @@ flag with_mpd   description: Build modules depending on libmpd. +flag with_hlist+  description: Build modules depending on HList.++flag with_template_haskell+  description: Build modules depending on template haskell.+ flag testing   description: Testing mode   default: False  library     if flag(small_base)-        build-depends: base >= 3 && < 4, containers, directory, process, random, old-time, old-locale+        build-depends: base >= 3 && < 5, containers, directory, process, random, old-time, old-locale     else         build-depends: base < 3 -    build-depends:      mtl, unix, X11>=1.4.3, xmonad>=0.9 && <1.0, xmonad-contrib>=0.9 && <1.0-    ghc-options:        -Wall+    build-depends:      mtl, unix, X11>=1.4.3, xmonad>=0.9 && <0.10, xmonad-contrib>=0.9 && <0.10 +    if true+        ghc-options:        -fwarn-tabs -Wall+     if flag(testing)         ghc-options:    -Werror @@ -45,17 +55,30 @@         ghc-options:    --disable-optimizations      if flag(with_parsec) && flag(with_split)-        build-depends: parsec, split+        build-depends: parsec >= 2 && < 4, split >= 0.1 && < 0.2         exposed-modules: XMonad.Actions.Volume      if flag(with_hint)-        build-depends: hint, network+        build-depends: hint >= 0.3 && < 0.4, network         exposed-modules: XMonad.Actions.Eval XMonad.Prompt.Eval --                         XMonad.Hooks.EvalServer      if flag(with_mpd)-        build-depends: libmpd+        build-depends: libmpd >= 0.5 && < 0.6         exposed-modules: XMonad.Prompt.MPD++    if impl(ghc >= 6.12.1) && flag(with_template_haskell) && flag(with_hlist)+        build-depends: template-haskell, HList >= 0.2.3 && < 0.3+        exposed-modules: XMonad.Config.Alt+                         XMonad.Config.Alt.Desktop+                         XMonad.Config.Alt.Sample+                         XMonad.Config.Alt.Internal+                         XMonad.Config.Alt.QQ++--    exposed-modules: XMonad.Hooks.PerWindowKbdLayout++    if impl(ghc >= 6.12.1)+        ghc-options:    -fno-warn-unused-do-bind  -- executable xmonadcmd --     main-is: XMonadCmd.hs