vision 0.0.2.4 → 0.0.3.0
raw patch · 28 files changed
+684/−229 lines, 28 filesdep +urldep ~xmms2-clientdep ~xmms2-client-glib
Dependencies added: url
Dependency ranges changed: xmms2-client, xmms2-client-glib
Files
- Makefile.in +1/−2
- src/Atoms.hs +12/−8
- src/Collection.hs +3/−0
- src/Collection/Control.hs +6/−8
- src/Collection/DnD.hs +47/−0
- src/Collection/Model.hs +2/−2
- src/Collection/Order.hs +0/−86
- src/Collection/UI.hs +12/−4
- src/DnD.hs +101/−35
- src/Location.hs +2/−0
- src/Location/DnD.hs +50/−0
- src/Playback.hs +2/−1
- src/Playlist/Control.hs +46/−0
- src/Playlist/DnD.hs +47/−2
- src/Playlist/Edit.hs +28/−14
- src/Playlist/Format.hs +2/−0
- src/Playlist/UI.hs +83/−6
- src/Properties.hs +2/−0
- src/Properties/Editor/Model.hs +8/−10
- src/Properties/Editor/UI.hs +1/−1
- src/Properties/Impex.hs +8/−13
- src/Properties/Model.hs +8/−6
- src/Properties/Order.hs +87/−0
- src/Properties/Property.hs +4/−1
- src/Properties/View.hs +107/−15
- src/Utils.hs +3/−8
- ui/playlist.xml +2/−0
- vision.cabal +10/−7
Makefile.in view
@@ -22,8 +22,7 @@ lint: rm -f hlint.out- -find ./src/ -type f -name "*.hs" -exec hlint {} \; | \- grep -v '^No suggestions$$' >> hlint.out+ -hlint src > hlint.out .PHONY: all-dev install build configure-dev clean lint else
src/Atoms.hs view
@@ -18,17 +18,21 @@ -- module Atoms- ( xmms2PosList- , xmms2MlibId- , propPosList- , mlibIdClipboard+ ( xmms2PosListTarget+ , xmms2MlibIdTarget+ , indexListTarget+ , propertyNameListTarget+ , uriListTarget+ , stringTarget ) where import Graphics.UI.Gtk import System.IO.Unsafe -xmms2PosList = unsafePerformIO $ atomNew "application/x-xmms2poslist"-xmms2MlibId = unsafePerformIO $ atomNew "application/x-xmms2mlibid"-propPosList = unsafePerformIO $ atomNew "application/x-visionpropposlist"-mlibIdClipboard = unsafePerformIO $ atomNew "_VISION_MEDIAID_CLIPBOARD"+xmms2PosListTarget = unsafePerformIO $ atomNew "application/x-xmms2poslist"+xmms2MlibIdTarget = unsafePerformIO $ atomNew "application/x-xmms2mlibid"+indexListTarget = unsafePerformIO $ atomNew "application/x-visionindexlist"+propertyNameListTarget = unsafePerformIO $ atomNew "application/x-visionpropertynamelist"+uriListTarget = unsafePerformIO $ atomNew "text/uri-list"+stringTarget = unsafePerformIO $ atomNew "STRING"
src/Collection.hs view
@@ -30,6 +30,7 @@ import Collection.Model import Collection.View import Collection.Control+import Collection.DnD import Collection.UI @@ -57,6 +58,8 @@ context <- initCollectionUI f let ?context = context++ setupDnD widgetShowAll window case maybeName of
src/Collection/Control.hs view
@@ -39,6 +39,7 @@ , showPropertyExport , getOrder , setOrder+ , getSelectedIds ) where import Prelude hiding (catch)@@ -146,7 +147,7 @@ applyFilter = do conn <- connected- when conn loadCurrent+ when conn loadSelected editFilter = do editableSelectRegion collFilter 0 (-1)@@ -163,14 +164,14 @@ name <- trim <$> getCurName coll <- getCurColl res <- runDlg "Save collection" (not $ null name) (const True) name- fmaybeM_ res $ \name -> do+ withJust res $ \name -> do collSave xmms coll name "Collections" return () renameCollection = do old <- fromJust <$> getSelectedCollection res <- runDlg "Rename collection" False (/= old) old- fmaybeM_ res $ \new -> do+ withJust res $ \new -> do collRename xmms old new "Collections" return () @@ -238,7 +239,7 @@ editCopy = do ids <- getSelectedIds clipboardSetWithData clipboard- [(xmms2MlibId, 0)]+ [(xmms2MlibIdTarget, 0)] (const $ selectionDataSet selectionTypeInteger ids) (return ()) return ()@@ -260,7 +261,4 @@ f =<< getSelectedIds getOrderKeys =- map orderKey <$> getOrder--orderKey (prop, False) = P.propKey prop-orderKey (prop, True) = '-' : P.propKey prop+ P.encodeOrder <$> getOrder
+ src/Collection/DnD.hs view
@@ -0,0 +1,47 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 15 Sep. 2010+--+-- Copyright (C) 2010 Oleg Belozeorov+--+-- 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 3 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.+--++module Collection.DnD+ ( setupDnD+ ) where++import Control.Monad.Trans++import Graphics.UI.Gtk++import Atoms++import Collection.Control+import Collection.View+++setupDnD = do+ targetList <- targetListNew+ targetListAdd targetList xmms2MlibIdTarget [TargetSameApp] 0++ dragSourceSet collView [Button1] [ActionCopy]+ dragSourceSetTargetList collView targetList++ collView `on` dragDataGet $ \_ _ _ -> do+ ids <- liftIO getSelectedIds+ selectionDataSet selectionTypeInteger ids+ return ()++ return ()+
src/Collection/Model.hs view
@@ -37,6 +37,7 @@ ) where import Control.Applicative+import Control.Arrow import Control.Monad import Control.Concurrent.MVar @@ -53,7 +54,6 @@ import Collection.Common import qualified Properties as P import Config-import Utils data State@@ -165,7 +165,7 @@ maybe Nothing (Just . (, desc)) <$> P.property name saveOrder order = do- writeConfig configFile $ map (mapFst P.propName) order+ writeConfig configFile $ map (first P.propName) order return () configFile =
− src/Collection/Order.hs
@@ -1,86 +0,0 @@--- -*-haskell-*---- Vision (for the Voice): an XMMS2 client.------ Author: Oleg Belozeorov--- Created: 10 Sep. 2010------ Copyright (C) 2010 Oleg Belozeorov------ 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 3 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.-----{-# LANGUAGE TupleSections #-}--module Collection.Order- ( OrderDialog- , makeOrderDialog- , showOrderDialog- ) where--import Control.Monad--import Graphics.UI.Gtk--import UI-import Compound-import Editor-import Properties-import Collection.Control---type OrderDialog = EditorDialog (PropertyView Bool)--showOrderDialog dialog =- runEditorDialog dialog- getOrder- setOrder- False window--makeOrderDialog =- makeEditorDialog [(stockApply, ResponseApply)]- makeOrderView $ \v -> do- let outerw = outer v- windowSetTitle outerw "Configure ordering"- windowSetDefaultSize outerw 500 400--makeOrderView parent onState = do- view <- makePropertyView (, False) parent onState- let store = propertyViewStore view- right = propertyViewRight view-- treeViewSetRulesHint right True-- column <- treeViewColumnNew- treeViewColumnSetTitle column "Order"- treeViewAppendColumn right column- cell <- cellRendererComboNew- treeViewColumnPackStart column cell True- cellLayoutSetAttributes column cell store $ \(_, dir) ->- [ cellText := dirToString dir ]-- cmod <- listStoreNewDND [False, True] Nothing Nothing- let clid = makeColumnIdString 0- customStoreSetColumn cmod clid dirToString- cell `set` [ cellTextEditable := True- , cellComboHasEntry := False- , cellComboTextModel := (cmod, clid) ]- cell `on` edited $ \[n] str -> do- (prop, dir) <- listStoreGetValue store n- let dir' = stringToDir str- unless (dir' == dir) $- listStoreSetValue store n (prop, dir')-- return view--dirToString False = "Ascending"-dirToString True = "Descending"--stringToDir = ("Descending" ==)
src/Collection/UI.hs view
@@ -35,11 +35,16 @@ import Handler import Utils import Context-import Properties (showPropertyImport, showPropertyManager)+import Properties+ ( showPropertyImport+ , showPropertyManager+ , OrderDialog+ , makeOrderDialog+ , showOrderDialog )+import Compound import Collection.View import Collection.List.View import Collection.Control-import Collection.Order data CollectionUI@@ -132,7 +137,10 @@ context <- initListView let ?context = context - orderDialog <- unsafeInterleaveIO makeOrderDialog+ orderDialog <- unsafeInterleaveIO $ makeOrderDialog $ \v -> do+ let outerw = outer v+ windowSetTitle outerw "Configure ordering"+ windowSetDefaultSize outerw 500 400 return $ augmentContext CollectionUI { cOrderDialog = orderDialog }@@ -201,7 +209,7 @@ , actionEntryStockId = Nothing , actionEntryAccelerator = Nothing , actionEntryTooltip = Nothing- , actionEntryCallback = showOrderDialog orderDialog+ , actionEntryCallback = showOrderDialog orderDialog getOrder setOrder } , ActionEntry { actionEntryName = "properties"
src/DnD.hs view
@@ -17,69 +17,125 @@ -- General Public License for more details. -- +{-# LANGUAGE TypeSynonymInstances, ExistentialQuantification #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module DnD- ( setupDnDReorder+ ( TargetClass (..)+ , CommonTargets (..)+ , Targets (..)+ , DragDest (..)+ , setupDragDest+ , getTargetRow+ , reorderRows+ , reorder+ , selectionDataGetStringList+ , selectionDataSetStringList ) where import Control.Applicative import Control.Monad import Control.Monad.Trans +import Data.List+import Data.Char import Data.IORef+import qualified Data.IntMap as IntMap import Graphics.UI.Gtk +import Utils -setupDnDReorder target store view apply = do- sel <- treeViewGetSelection view - targetList <- targetListNew- targetListAdd targetList target [TargetSameWidget] 0+class TargetClass t where+ addToTargetList :: TargetList -> InfoId -> t -> IO () - dropRef <- newIORef False - dragSourceSet view [Button1] [ActionMove]- dragSourceSetTargetList view targetList+instance TargetClass TargetTag where+ addToTargetList tl id tg = targetListAdd tl tg [] id - view `on` dragDataGet $ \_ _ _ -> do- rows <- liftIO $ treeSelectionGetSelectedRows sel- selectionDataSet selectionTypeInteger $ map head rows- return () - dragDestSet view [DestDefaultMotion, DestDefaultHighlight] [ActionMove]- dragDestSetTargetList view targetList+data CommonTargets+ = URITargets - view `on` dragDrop $ \ctxt _ tstamp -> do- writeIORef dropRef True- dragGetData view ctxt target tstamp- return True+instance TargetClass CommonTargets where+ addToTargetList tl id tg =+ case tg of+ URITargets -> targetListAddUriTargets tl id - view `on` dragDataReceived $ \ctxt (_, y) _ tstamp -> do++data Targets+ = forall t1 t2. (TargetClass t1, TargetClass t2) => t1 :|: t2++infixr 5 :|:++instance TargetClass Targets where+ addToTargetList tl id (t1 :|: t2) = do+ addToTargetList tl id t1+ addToTargetList tl id t2+++data DragDest+ = forall t. TargetClass t => t :>: (DragContext -> Point -> SelectionDataM (Bool, Bool))++infix 4 :>:+++setupDragDest widget defs acts dests = do+ tl <- targetListNew+ hm <- IntMap.fromList <$> zipWithM (mk tl) [0 .. ] dests++ dragDestSet widget defs acts+ dragDestSetTargetList widget tl++ dropRef <- newIORef False++ widget `on` dragDrop $ \ctxt _ tstamp -> do+ maybeTarget <- dragDestFindTarget widget ctxt (Just tl)+ case maybeTarget of+ Just target -> do+ writeIORef dropRef True+ dragGetData widget ctxt target tstamp+ return True+ Nothing ->+ return False++ widget `on` dragDataReceived $ \ctxt pos infoId tstamp -> do drop <- liftIO $ readIORef dropRef when drop $ do liftIO $ writeIORef dropRef False- (rows :: Maybe [Int]) <- selectionDataGet selectionTypeInteger- liftIO $ doReorder apply store view y rows- liftIO $ dragFinish ctxt True True tstamp+ (ok, del) <- case IntMap.lookup (fromIntegral infoId) hm of+ Just handler -> handler ctxt pos+ Nothing -> return (False, False)+ liftIO $ dragFinish ctxt ok del tstamp - view `on` dragDataDelete $ \_ ->- treeSelectionUnselectAll sel+ return () + where mk tl id (ts :>: handler) = do+ addToTargetList tl id ts+ return (fromIntegral id, handler) -doReorder _ _ _ _ Nothing = return ()-doReorder apply store view y (Just rows) = do- base <- getTargetRow- apply $ reorder base rows- where getTargetRow = do- maybePos <- treeViewGetPathAtPos view (0, y)- case maybePos of- Just ([n], _, _) ->- return n- Nothing ->- pred <$> listStoreGetSize store +getTargetRow store view y reorder = do+ maybePos <- treeViewGetPathAtPos view (0, y)+ case maybePos of+ Just ([n], _, _) | reorder ->+ return n+ Just ([n], column, _) -> do+ Rectangle _ cy _ ch <- treeViewGetCellArea view (Just [n]) column+ return $ if y - cy > 2 * ch `div` 3 then n + 1 else n+ Nothing | reorder ->+ pred <$> listStoreGetSize store+ Nothing ->+ listStoreGetSize store++reorderRows store view f _ (_, y) = do+ rows <- selectionDataGet selectionTypeInteger+ liftIO $ withJust rows $ \rows -> do+ base <- getTargetRow store view y True+ f $ reorder base rows+ return (True, False)+ reorder = reorderDown 0 where reorderDown _ _ [] = [] reorderDown dec base rows@(r:rs)@@ -89,4 +145,14 @@ reorderUp base (r:rs) | r == base = reorderUp (base + 1) rs | otherwise = (r, base) : reorderUp (base + 1) rs+++selectionDataSetStringList =+ selectionDataSet selectionTypeInteger . intercalate [0] . map (map ord)++selectionDataGetStringList =+ maybe [] brk <$> selectionDataGet selectionTypeInteger+ where brk text = case break (== 0) text of+ (name, []) -> [map chr name]+ (name, _ : rest) -> map chr name : brk rest
src/Location.hs view
@@ -28,6 +28,7 @@ import Location.History import Location.Model import Location.View+import Location.DnD import Location.Control import Location.UI @@ -49,6 +50,7 @@ let ?context = context setupUI f+ setupDnD widgetShowAll window case maybeURL of
+ src/Location/DnD.hs view
@@ -0,0 +1,50 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 16 Sep. 2010+--+-- Copyright (C) 2010 Oleg Belozeorov+--+-- 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 3 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.+--++module Location.DnD+ ( setupDnD+ ) where++import Control.Monad.Trans++import Network.URL++import Graphics.UI.Gtk++import Location.Model+import Location.View+++setupDnD = do+ targetList <- targetListNew+ targetListAddUriTargets targetList 0++ dragSourceSet locationView [Button1] [ActionCopy]+ dragSourceSetTargetList locationView targetList++ locationView `on` dragDataGet $ \_ _ _ -> do+ paths <- liftIO $ do+ rows <- treeSelectionGetSelectedRows locationSel+ items <- mapM itemByPath rows+ return $ map (encString False ok_url . iPath) items+ selectionDataSetURIs paths+ return ()++ return ()+
src/Playback.hs view
@@ -33,6 +33,7 @@ , requestCurrentTrack ) where +import Control.Arrow import Control.Concurrent.MVar import Control.Monad.Trans @@ -124,7 +125,7 @@ requestCurrentTrack = playlistCurrentPos xmms Nothing >>* do- new <- catchResult Nothing (Just . mapFst fromIntegral)+ new <- catchResult Nothing (Just . first fromIntegral) liftIO $ do old <- modifyMVar state $ \state -> return (state { sCurrentTrack = new }, sCurrentTrack state)
src/Playlist/Control.hs view
@@ -26,13 +26,22 @@ , playTrack , showPropertyEditor , showPropertyExport+ , getOrder+ , setOrder+ , insertURIs ) where import Control.Monad+import Control.Monad.Trans +import Data.Maybe++import Network.URL+ import XMMS2.Client import XMMS+import Utils import Playback import qualified Properties as P import Playlist.Model@@ -77,3 +86,40 @@ withSelectedIds f = f =<< playlistGetIds =<< getSelectedTracks++getOrder =+ return []++setOrder order = do+ name <- getPlaylistName+ playlistSort xmms name $ P.encodeOrder order+ return ()++insertURIs uris pos = do+ name <- getPlaylistName+ base <- case pos of+ Just n -> return n+ Nothing -> getPlaylistSize+ insertURIs' name base . mapMaybe (decString False) $ reverse uris++insertURIs' _ _ [] = return ()+insertURIs' name base (uri : rest) =+ xformMediaBrowse xmms uri >>* do+ isDir <- catchResult False (const True)+ liftIO $+ if isDir+ then do+ playlistRInsert xmms name base uri+ insertURIs' name base rest+ else do+ let insertColl coll = do+ playlistInsertCollection xmms name base coll []+ return ()+ insertURL = do+ playlistInsertURL xmms name base uri+ return ()+ collIdlistFromPlaylistFile xmms uri >>* do+ func <- catchResult insertURL insertColl+ liftIO $ do+ func+ insertURIs' name base rest
src/Playlist/DnD.hs view
@@ -21,12 +21,57 @@ ( setupDnD ) where +import Control.Monad+import Control.Monad.Trans++import Graphics.UI.Gtk++import XMMS2.Client+ import Atoms+import XMMS+import Utils import DnD+ import Playlist.Model import Playlist.View import Playlist.Control -setupDnD =- setupDnDReorder xmms2PosList playlistStore playlistView moveTracks+setupDnD = do+ let view = playlistView+ store = playlistStore++ targetList <- targetListNew+ targetListAdd targetList xmms2PosListTarget [TargetSameWidget] 0++ dragSourceSet view [Button1] [ActionMove]+ dragSourceSetTargetList view targetList++ sel <- treeViewGetSelection view+ view `on` dragDataGet $ \_ _ _ -> do+ rows <- liftIO $ treeSelectionGetSelectedRows sel+ selectionDataSet selectionTypeInteger $ map head rows+ return ()++ setupDragDest view+ [DestDefaultMotion, DestDefaultHighlight]+ [ActionMove, ActionCopy]+ [ xmms2PosListTarget :>: reorderRows store view moveTracks+ , xmms2MlibIdTarget :>: \_ (_, y) -> do+ ids <- selectionDataGet selectionTypeInteger+ liftIO $ withJust ids $ \ids -> do+ name <- getPlaylistName+ base <- getTargetRow store view y False+ zipWithM_ (playlistInsertId xmms name) [base .. ] ids+ return (True, False)+ , URITargets :>: \_ (_, y) -> do+ uris <- selectionDataGetURIs+ liftIO $ withJust uris $ \uris -> do+ base <- getTargetRow store view y False+ insertURIs uris $ Just base+ return (True, False)+ ]++ view `on` dragDataDelete $ \_ ->+ treeSelectionUnselectAll sel
src/Playlist/Edit.hs view
@@ -26,7 +26,6 @@ , editCheckClipboard ) where -import Control.Applicative import Control.Monad import Control.Monad.Trans @@ -46,19 +45,31 @@ when cut $ copyIds tracks removeTracks tracks maybeTrack <- currentTrackThisPlaylist- fmaybeM_ maybeTrack $ \t ->+ withJust maybeTrack $ \t -> when (t `elem` tracks) restartPlayback editCopy = copyIds =<< getSelectedTracks -editPaste append =- clipboardRequestContents clipboard xmms2MlibId $ do- maybeIds <- selectionDataGet selectionTypeInteger- fmaybeM_ maybeIds $ \ids -> liftIO $ do- (path, _) <- treeViewGetCursor playlistView- insertIds ids $ case path of- [n] | not append -> Just n- _ -> Nothing+editPaste append = do+ targets <- getClipboardTargets+ paste targets+ where paste targets+ | xmms2MlibIdTarget `elem` targets =+ p xmms2MlibIdTarget (selectionDataGet selectionTypeInteger) insertIds+ | uriListTarget `elem` targets =+ p uriListTarget selectionDataGetURIs insertURIs+ | stringTarget `elem` targets =+ p stringTarget selectionDataGetText $ insertURIs . lines+ | otherwise =+ return ()+ p target get put =+ clipboardRequestContents clipboard target $ do+ maybeContents <- get+ withJust maybeContents $ \contents -> liftIO $ do+ (path, _) <- treeViewGetCursor playlistView+ put contents $ case path of+ [n] | not append -> Just n+ _ -> Nothing editSelectAll = treeSelectionSelectAll playlistSel@@ -68,14 +79,17 @@ treeSelectionSelectAll playlistSel mapM_ (treeSelectionUnselectPath playlistSel) rows -editCheckClipboard =- elem xmms2MlibId <$> getClipboardTargets-+editCheckClipboard = do+ targets <- getClipboardTargets+ return $+ elem xmms2MlibIdTarget targets ||+ elem uriListTarget targets ||+ elem stringTarget targets copyIds tracks = do ids <- playlistGetIds tracks clipboardSetWithData clipboard- [(xmms2MlibId, 0)]+ [(xmms2MlibIdTarget, 0)] (const $ selectionDataSet selectionTypeInteger ids) (return ()) return ()
src/Playlist/Format.hs view
@@ -136,6 +136,8 @@ \{Performer}][\n\ \[{Conductor}, ]{Orchestra}][\n\ \[{Chorus master}, ]{Chorus}]"+ , "[<b>{Title}</b>\n]\+ \{Channel}" , "[{Track} ]<b>{Title}</b>\n\ \{Artist} — {Album}" ]
src/Playlist/UI.hs view
@@ -21,10 +21,14 @@ ( setupUI ) where -import Graphics.UI.Gtk hiding (add)+import System.IO.Unsafe -import XMMS2.Client+import Network.URL +import Graphics.UI.Gtk hiding (add, remove)++import XMMS2.Client hiding (Data)+ import UI import XMMS import Handler@@ -35,6 +39,8 @@ import Clipboard import Location import Collection+import Compound+import Editor import Properties hiding (showPropertyEditor, showPropertyExport) import Playlist.Model import Playlist.View@@ -46,8 +52,21 @@ setupUI = do addUIActions uiActions + orderDialog <- unsafeInterleaveIO $ makeOrderDialog $ \v -> do+ let outerw = outer v+ updateTitle = do+ name <- getPlaylistName+ windowSetTitle outerw $+ "Sort playlist" ++ maybe "" (": " ++) name+ cid <- onPlaylistUpdated . add . ever . const $ updateTitle+ outerw `onDestroy` (onPlaylistUpdated $ remove cid)+ updateTitle+ windowSetDefaultSize outerw 500 400++ urlEntryDialog <- unsafeInterleaveIO $ makeURLEntryDialog+ srvAG <- actionGroupNew "server"- actionGroupAddActions srvAG srvActions+ actionGroupAddActions srvAG $ srvActions orderDialog urlEntryDialog onServerConnectionAdd . ever $ actionGroupSetSensitive srvAG insertActionGroup srvAG 1 @@ -115,6 +134,7 @@ scroll <- scrolledWindowNew Nothing Nothing scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic+ scrolledWindowSetShadowType scroll ShadowIn containerAdd scroll playlistView boxPackStartDefaults contents scroll @@ -218,12 +238,12 @@ } ] -srvActions =+srvActions orderDialog urlEntryDialog = [ ActionEntry { actionEntryName = "play" , actionEntryLabel = "_Play" , actionEntryStockId = Just stockMediaPlay- , actionEntryAccelerator = Just "<Control>space"+ , actionEntryAccelerator = Just "<Control>Return" , actionEntryTooltip = Nothing , actionEntryCallback = startPlayback False }@@ -231,7 +251,7 @@ { actionEntryName = "pause" , actionEntryLabel = "_Pause" , actionEntryStockId = Just stockMediaPause- , actionEntryAccelerator = Just "<Control>space"+ , actionEntryAccelerator = Just "<Control>Return" , actionEntryTooltip = Nothing , actionEntryCallback = pausePlayback }@@ -332,6 +352,14 @@ , actionEntryCallback = browseCollection Nothing } , ActionEntry+ { actionEntryName = "add-media"+ , actionEntryLabel = "_Add media"+ , actionEntryStockId = Just stockAdd+ , actionEntryAccelerator = Nothing+ , actionEntryTooltip = Nothing+ , actionEntryCallback = runURLEntryDialog urlEntryDialog+ }+ , ActionEntry { actionEntryName = "clear-playlist" , actionEntryLabel = "_Clear playlist" , actionEntryStockId = Just stockClear@@ -340,6 +368,14 @@ , actionEntryCallback = clearPlaylist } , ActionEntry+ { actionEntryName = "sort-by"+ , actionEntryLabel = "_Sort by…"+ , actionEntryStockId = Nothing+ , actionEntryAccelerator = Nothing+ , actionEntryTooltip = Nothing+ , actionEntryCallback = showOrderDialog orderDialog getOrder setOrder+ }+ , ActionEntry { actionEntryName = "edit-properties" , actionEntryLabel = "_Edit properties" , actionEntryStockId = Just stockEdit@@ -364,3 +400,44 @@ , actionEntryCallback = showPropertyImport } ]+++data URLEntry =+ URLEntry { urlEntry :: Entry+ , urlBox :: HBox+ }++instance CompoundWidget URLEntry where+ type Outer URLEntry = HBox+ outer = urlBox++instance EditorWidget URLEntry where+ type Data URLEntry = String+ setData e = entrySetText (urlEntry e)+ getData = entryGetText . urlEntry+ clearData = flip setData ""+ getState = const $ return (True, True)+ resetModified = const $ return ()+ focusView = widgetGrabFocus . urlEntry++makeURLEntry _ _ = do+ box <- hBoxNew False 0+ containerSetBorderWidth box 7+ entry <- entryNew+ entrySetActivatesDefault entry True+ boxPackStartDefaults box entry+ return URLEntry { urlEntry = entry+ , urlBox = box+ }++makeURLEntryDialog =+ makeEditorDialog [] makeURLEntry $ \v -> do+ let outerw = outer v+ windowSetTitle outerw "Add media"+ windowSetDefaultSize outerw 500 (-1)++runURLEntryDialog dlg =+ runEditorDialog dlg (return "")+ (\str ->+ insertURIs (map (encString False ok_url) $ lines str) Nothing)+ False window
src/Properties.hs view
@@ -31,6 +31,7 @@ , showPropertyExport , showPropertyImport , module Properties.View+ , module Properties.Order ) where import Prelude hiding (lookup)@@ -41,6 +42,7 @@ import Properties.Manager import Properties.Editor import Properties.Impex+import Properties.Order initProperties = do
src/Properties/Editor/Model.hs view
@@ -39,9 +39,9 @@ import Control.Arrow import Data.Maybe-import Data.List hiding (lookup)+import Data.List hiding (lookup, union) import Data.Array-import Data.Map (Map)+import Data.Map (Map, union) import qualified Data.Map as Map import Graphics.UI.Gtk hiding (add, get, Entry)@@ -250,15 +250,13 @@ extractChanges = do s <- get let c = sCurrent s- e = case sPerTrack s of- True ->- Map.insert (sIds s ! sPos s) c (sEntries s)- False ->- let u = snd c in- Map.map (second $ Map.union u) $ sEntries s- e' = Map.map (\(b, c) -> (Map.union c b, Map.empty)) e+ e = if sPerTrack s+ then Map.insert (sIds s ! sPos s) c (sEntries s)+ else let u = snd c in+ Map.map (second $ union u) $ sEntries s+ e' = Map.map (\(b, c) -> (c `union` b, Map.empty)) e put s { sEntries = e'- , sCurrent = (Map.union (snd c) (fst c), Map.empty)+ , sCurrent = (snd c `union` fst c, Map.empty) } return $ map (\(id, (_, c)) -> (id, Map.toList c)) $ Map.toList e
src/Properties/Editor/UI.hs view
@@ -64,7 +64,7 @@ setRetrievalCancel = writeIORef (uCancel context) . Just cancelRetrieval = do cancel' <- readIORef (uCancel context)- fmaybeM_ cancel' id+ withJust cancel' id writeIORef (uCancel context) Nothing
src/Properties/Impex.hs view
@@ -86,18 +86,13 @@ makeExportDlg = makeChooser "Export properties" FileChooserActionSave stockSave -exportProps ids file = do- pbar <- progressBarNew -- FIXME- retrieveProperties ids $ \prog ->- case prog of- Left _ -> return ()- Right list -> do- let base = dropFileName $ decodeString file- text = encodeStrict $ showJSON $ map (exConv base . snd) list- widgetDestroy pbar -- FIXME- writeFile file text `catch` \e ->- putStrLn $ "Export failed" ++- (decodeString file) ++ ": " ++ ioeGetErrorString e+exportProps ids file =+ retrieveProperties ids $ either (const $ return ()) $ \list -> do+ let base = dropFileName $ decodeString file+ text = encodeStrict $ showJSON $ map (exConv base . snd) list+ writeFile file text `catch` \e ->+ putStrLn $ "Export failed" +++ (decodeString file) ++ ": " ++ ioeGetErrorString e exConv base info = ((url', args), Map.difference info readOnlyProps) where url' = stripBase $ decodeURL path@@ -184,7 +179,7 @@ case resp of ResponseAccept -> do name <- fileChooserGetFilename chooser- fmaybeM_ name onAccept+ withJust name onAccept _ -> return () widgetHide chooser
src/Properties/Model.hs view
@@ -80,9 +80,10 @@ loadProperties = do props <- config "properties.conf" [] mapM_ (listStoreAppend propertyStore) =<<- (modifyMVar propertyMap $ \m -> do- let m' = Map.union m $ mkMap props- return (m', Map.elems m'))+ modifyMVar propertyMap+ (\m ->+ let m' = Map.union m $ mkMap props in+ return (m', Map.elems m')) getProperties = withMVar propertyMap $ return . Map.elems@@ -90,9 +91,10 @@ setProperties props = do listStoreClear propertyStore mapM_ (listStoreAppend propertyStore) =<<- (modifyMVar propertyMap $ const $ do- let m = mkMap props- return (m, Map.elems m))+ modifyMVar propertyMap+ (const $+ let m = mkMap props in+ return (m, Map.elems m)) writeConfig "properties.conf" props onProperties $ invoke ()
+ src/Properties/Order.hs view
@@ -0,0 +1,87 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 10 Sep. 2010+--+-- Copyright (C) 2010 Oleg Belozeorov+--+-- 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 3 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.+--++{-# LANGUAGE TupleSections #-}++module Properties.Order+ ( OrderDialog+ , makeOrderDialog+ , showOrderDialog+ , encodeOrder+ ) where++import Control.Monad++import Graphics.UI.Gtk++import UI+import Editor+import Properties.Property+import Properties.View+++type OrderDialog = EditorDialog (PropertyView Bool)+++showOrderDialog dialog getOrder setOrder =+ runEditorDialog dialog+ getOrder+ setOrder+ False window++makeOrderDialog =+ makeEditorDialog [(stockApply, ResponseApply)] makeOrderView++makeOrderView parent onState = do+ view <- makePropertyView (, False) parent onState+ let store = propertyViewStore view+ right = propertyViewRight view++ treeViewSetRulesHint right True++ column <- treeViewColumnNew+ treeViewColumnSetTitle column "Order"+ treeViewAppendColumn right column+ cell <- cellRendererComboNew+ treeViewColumnPackStart column cell True+ cellLayoutSetAttributes column cell store $ \(_, dir) ->+ [ cellText := dirToString dir ]++ cmod <- listStoreNewDND [False, True] Nothing Nothing+ let clid = makeColumnIdString 0+ customStoreSetColumn cmod clid dirToString+ cell `set` [ cellTextEditable := True+ , cellComboHasEntry := False+ , cellComboTextModel := (cmod, clid) ]+ cell `on` edited $ \[n] str -> do+ (prop, dir) <- listStoreGetValue store n+ let dir' = stringToDir str+ unless (dir' == dir) $+ listStoreSetValue store n (prop, dir')++ return view++dirToString False = "Ascending"+dirToString True = "Descending"++stringToDir = ("Descending" ==)++encodeOrder = map enc+ where enc (prop, False) = propKey prop+ enc (prop, True) = '-' : propKey prop
src/Properties/Property.hs view
@@ -32,6 +32,7 @@ import Prelude hiding (lookup) import Control.Applicative+import Control.Arrow import Control.Monad import Data.Maybe@@ -74,7 +75,7 @@ , propShowValue :: Maybe PropertyShow } instance Read Property where- readsPrec x s = map (mapFst mk) (readsPrec x s)+ readsPrec x s = map (first mk) (readsPrec x s) instance Show Property where show p = show (propName p, propKey p, propType p, propReadOnly p)@@ -162,6 +163,8 @@ , ("Chorus master", "chorus_master", PropertyString, False, Nothing, Nothing) , ("Chorus", "chorus",+ PropertyString, False, Nothing, Nothing)+ , ("Channel", "channel", PropertyString, False, Nothing, Nothing) ]
src/Properties/View.hs view
@@ -26,17 +26,22 @@ , propertyViewRight ) where +import Control.Applicative import Control.Monad import Control.Monad.Trans import Data.IORef+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set import Graphics.UI.Gtk import Atoms-import DnD import Compound import Editor+import DnD+ import Properties.Property import Properties.Model @@ -44,10 +49,12 @@ data PropertyView a = PropertyView { vPaned :: HPaned+ , vFilter :: TreeModelFilter , vLeft :: TreeView , propertyViewStore :: ListStore (Property, a) , propertyViewRight :: TreeView , vModified :: IORef Bool+ , vSelected :: IORef (Set String) } instance CompoundWidget (PropertyView a) where@@ -70,9 +77,11 @@ propertyViewSetData v d = do listStoreClear $ propertyViewStore v mapM_ (listStoreAppend $ propertyViewStore v) d+ writeIORef (vSelected v) $ Set.fromList $ map (propName . fst) d+ treeModelFilterRefilter (vFilter v) propertyViewClearData =- listStoreClear . propertyViewStore+ flip propertyViewSetData [] propertyViewSetupView pm = treeViewSetCursor (vLeft pm) [0] Nothing@@ -87,6 +96,8 @@ flip writeIORef False . vModified makePropertyView make _ notify = do+ selected <- newIORef Set.empty+ modified <- newIORef False let onChanged = do writeIORef modified True@@ -100,7 +111,14 @@ scrolledWindowSetShadowType scroll ShadowIn panedPack1 paned scroll True False - left <- treeViewNewWithModel propertyStore+ filter <- treeModelFilterNew propertyStore []+ treeModelFilterSetVisibleFunc filter $ Just $ \iter -> do+ [n] <- treeModelGetPath propertyStore iter+ prop <- listStoreGetValue propertyStore n+ seld <- readIORef selected+ return $ Set.notMember (propName prop) seld++ left <- treeViewNewWithModel filter treeViewSetHeadersVisible left False sel <- treeViewGetSelection left@@ -141,34 +159,108 @@ containerAdd scroll right + let updFilter func props = do+ modifyIORef selected $ func (Set.fromList $ map propName props)+ treeModelFilterRefilter filter+ addProps = do+ sel <- treeViewGetSelection left+ rows <- treeSelectionGetSelectedRows sel+ rows <- mapM (treeModelFilterConvertPathToChildPath filter) rows+ props <- mapM (listStoreGetValue propertyStore . head) rows+ mapM (listStoreAppend store . make) props+ updFilter Set.union props++ left `onRowActivated` \_ _ -> addProps+ left `on` keyPressEvent $ tryEvent $ do [] <- eventModifier "Return" <- eventKeyName- liftIO $ do- sel <- treeViewGetSelection left- rows <- treeSelectionGetSelectedRows sel- forM_ rows $ \[n] ->- listStoreAppend store . make =<<- listStoreGetValue propertyStore n+ liftIO addProps + setupLeftDnD filter left+ right `on` keyPressEvent $ tryEvent $ do [] <- eventModifier "Delete" <- eventKeyName liftIO $ do- sel <- treeViewGetSelection right- rows <- treeSelectionGetSelectedRows sel+ sel <- treeViewGetSelection right+ rows <- treeSelectionGetSelectedRows sel+ props <- mapM (listStoreGetValue store . head) rows mapM_ (listStoreRemove store . head) $ reverse rows+ updFilter (flip Set.difference) $ map fst props - setupDnDReorder propPosList store right . mapM_ $ \(f, t) -> do- v <- listStoreGetValue store f- listStoreRemove store f- listStoreInsert store t v + setupRightDnD store right make updFilter+ return PropertyView { vPaned = paned+ , vFilter = toTreeModelFilter filter , vLeft = left , propertyViewStore = store , propertyViewRight = right , vModified = modified+ , vSelected = selected } +setupLeftDnD filter left = do+ targetList <- targetListNew+ targetListAdd targetList propertyNameListTarget [TargetSameApp] 0++ dragSourceSet left [Button1] [ActionCopy]+ dragSourceSetTargetList left targetList++ sel <- treeViewGetSelection left+ left `on` dragDataGet $ \_ _ _ -> do+ names <- liftIO $ do+ rows <- treeSelectionGetSelectedRows sel+ rows <- mapM (treeModelFilterConvertPathToChildPath filter) rows+ mapM (liftM propName . listStoreGetValue propertyStore . head) rows+ selectionDataSetStringList names++ setupDragDest left+ [DestDefaultMotion, DestDefaultHighlight]+ [ActionMove]+ [ indexListTarget :>: \_ _ -> do+ liftIO $ signalStopEmission left "drag_data_received"+ return (True, True)+ ]++ return ()+++setupRightDnD store view make updFilter = do+ targetList <- targetListNew+ targetListAdd targetList indexListTarget [TargetSameApp] 0++ dragSourceSet view [Button1] [ActionDefault, ActionMove]+ dragSourceSetTargetList view targetList++ sel <- treeViewGetSelection view+ view `on` dragDataGet $ \_ _ _ -> do+ rows <- liftIO $ treeSelectionGetSelectedRows sel+ selectionDataSet selectionTypeInteger $ map head rows+ return ()++ setupDragDest view+ [DestDefaultMotion, DestDefaultHighlight]+ [ActionCopy, ActionDefault]+ [ indexListTarget :>: reorderRows store view+ (mapM_ $ \(f, t) -> do+ v <- listStoreGetValue store f+ listStoreRemove store f+ listStoreInsert store t v)+ , propertyNameListTarget :>: \_ (_, y) -> do+ names <- selectionDataGetStringList+ liftIO $ do+ props <- map make . catMaybes <$> mapM property names+ base <- getTargetRow store view y False+ zipWithM_ (listStoreInsert store) [base .. ] props+ updFilter Set.union $ map fst props+ return (True, False)+ ]++ view `on` dragDataDelete $ \_ -> do+ rows <- treeSelectionGetSelectedRows sel+ props <- mapM (listStoreGetValue store . head) rows+ mapM_ (listStoreRemove store . head) $ reverse rows+ updFilter (flip Set.difference) $ map fst props
src/Utils.hs view
@@ -21,8 +21,6 @@ ( HandlerMVar , makeHandlerMVar , onHandler- , mapFst- , mapSnd , encodeURL , decodeURL , trd@@ -31,7 +29,7 @@ , catchResult , setupTreeViewPopup , dialogAddButtonCR- , fmaybeM_+ , withJust , withSignalBlocked , hideOnDeleteEvent , eqBy@@ -61,9 +59,6 @@ onHandler = modifyMVar -mapFst f (a, b) = (f a, b)-mapSnd f (a, b) = (a, f b)- encodeURL = encodeURL' . encodeString encodeURL' [] = [] encodeURL' (' ':cs) = '+' : encodeURL' cs@@ -147,8 +142,8 @@ fmaybe :: b -> Maybe a -> (a -> b) -> b fmaybe = flip . maybe -fmaybeM_ :: Monad m => Maybe a -> (a -> m b) -> m ()-fmaybeM_ m f = fmaybe (return ()) m $ \a -> f a >> return ()+withJust :: Monad m => Maybe a -> (a -> m b) -> m ()+withJust m f = fmaybe (return ()) m $ \a -> f a >> return () withSignalBlocked s f = block $ do
ui/playlist.xml view
@@ -25,7 +25,9 @@ <menuitem action="browse-collection"/> </menu> <menu action="playlist">+ <menuitem action="add-media"/> <menuitem action="clear-playlist"/>+ <menuitem action="sort-by"/> <separator/> <menuitem action="configure-playlist"/> </menu>
vision.cabal view
@@ -1,5 +1,5 @@ name: vision-version: 0.0.2.4+version: 0.0.3.0 author: Oleg Belozeorov maintainer: Oleg Belozeorov <upwawet@gmail.com>@@ -57,6 +57,7 @@ Properties.Editor.View, Properties.Editor.UI, Properties.Impex,+ Properties.Order, Playback, Volume, Playtime,@@ -66,6 +67,7 @@ Location.History, Location.Model, Location.View,+ Location.DnD, Location.Control, Location.UI, Collection,@@ -76,7 +78,7 @@ Collection.Model, Collection.View, Collection.Control,- Collection.Order,+ Collection.DnD, Collection.UI, Playlist, Playlist.Model,@@ -94,11 +96,12 @@ Playlist.Format.Parser, Playlist.Format.Config hs-source-dirs: src- build-depends: base >= 4 && < 5, xmms2-client >= 0.0.4.0,- xmms2-client-glib >= 0.0.4.0,+ build-depends: base >= 4 && < 5, xmms2-client >= 0.0.5.0,+ xmms2-client-glib >= 0.0.5.0, gtk, containers, mtl, utf8-string, filepath, directory, glib, array,- MonadCatchIO-mtl, json, parsec >= 3.0.1+ MonadCatchIO-mtl, json, parsec >= 3.0.1,+ url extensions: ImplicitParams, NoMonomorphismRestriction, FlexibleContexts, FlexibleInstances, TypeFamilies, ScopedTypeVariables,@@ -111,7 +114,7 @@ type: git location: git://github.com/upwawet/vision.git -source-repository head+source-repository this type: git location: git://github.com/upwawet/vision.git- tag: v0.0.2.4+ tag: v0.0.3.0