diff --git a/XMonad/Actions/Eval.hs b/XMonad/Actions/Eval.hs --- a/XMonad/Actions/Eval.hs +++ b/XMonad/Actions/Eval.hs @@ -28,7 +28,6 @@ import XMonad.Core import XMonad.Util.Run import Language.Haskell.Interpreter -import Control.Monad import Data.List -- $usage diff --git a/XMonad/Actions/Volume.hs b/XMonad/Actions/Volume.hs --- a/XMonad/Actions/Volume.hs +++ b/XMonad/Actions/Volume.hs @@ -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 () diff --git a/XMonad/Config/Alt.hs b/XMonad/Config/Alt.hs new file mode 100644 --- /dev/null +++ b/XMonad/Config/Alt.hs @@ -0,0 +1,38 @@ +{- | + +Module : XMonad.Config.Alt +Copyright : Adam Vogt +License : BSD3-style (see LICENSE) + +Maintainer : Adam Vogt +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 diff --git a/XMonad/Config/Alt/Desktop.hs b/XMonad/Config/Alt/Desktop.hs new file mode 100644 --- /dev/null +++ b/XMonad/Config/Alt/Desktop.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +{- | +Module : XMonad.Config.Alt.Desktop +Copyright : Adam Vogt +License : BSD3-style (see LICENSE) + +Maintainer : Adam Vogt +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 diff --git a/XMonad/Config/Alt/Internal.hs b/XMonad/Config/Alt/Internal.hs new file mode 100644 --- /dev/null +++ b/XMonad/Config/Alt/Internal.hs @@ -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 +License : BSD3-style (see LICENSE) + +Maintainer : Adam Vogt +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"] + ] + ) diff --git a/XMonad/Config/Alt/QQ.hs b/XMonad/Config/Alt/QQ.hs new file mode 100644 --- /dev/null +++ b/XMonad/Config/Alt/QQ.hs @@ -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] diff --git a/XMonad/Config/Alt/Sample.hs b/XMonad/Config/Alt/Sample.hs new file mode 100644 --- /dev/null +++ b/XMonad/Config/Alt/Sample.hs @@ -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' diff --git a/XMonad/Prompt/MPD.hs b/XMonad/Prompt/MPD.hs --- a/XMonad/Prompt/MPD.hs +++ b/XMonad/Prompt/MPD.hs @@ -1,22 +1,21 @@ -{-# LANGUAGE PatternGuards, Rank2Types #-} +{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : XMonad.Prompt.MPD --- Copyright : Daniel Schoepe +-- Copyright : Daniel Schoepe -- License : BSD3-style (see LICENSE) -- --- Maintainer : Daniel Schoepe +-- Maintainer : Daniel Schoepe -- 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 () diff --git a/xmonad-extras.cabal b/xmonad-extras.cabal --- a/xmonad-extras.cabal +++ b/xmonad-extras.cabal @@ -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