vision 0.0.4.0 → 0.0.5.0
raw patch · 73 files changed
+3112/−2103 lines, 73 filesdep +MonadCatchIO-transformersdep +PSQueuedep +stmdep −MonadCatchIO-mtldep ~xmms2-clientdep ~xmms2-client-glib
Dependencies added: MonadCatchIO-transformers, PSQueue, stm
Dependencies removed: MonadCatchIO-mtl
Dependency ranges changed: xmms2-client, xmms2-client-glib
Files
- configure +158/−113
- configure.ac +6/−1
- src/About.hs +2/−2
- src/Clipboard.hs +55/−48
- src/Collection.hs +53/−29
- src/Collection/Actions.hs +47/−0
- src/Collection/Combo.hs +62/−0
- src/Collection/ComboModel.hs +41/−0
- src/Collection/Common.hs +110/−11
- src/Collection/Control.hs +0/−264
- src/Collection/DnD.hs +0/−47
- src/Collection/List.hs +3/−5
- src/Collection/List/Model.hs +57/−30
- src/Collection/List/View.hs +117/−72
- src/Collection/Model.hs +0/−172
- src/Collection/PropFlt.hs +180/−0
- src/Collection/ScrollBox.hs +53/−0
- src/Collection/Select.hs +89/−0
- src/Collection/Tracks.hs +206/−0
- src/Collection/UI.hs +0/−156
- src/Collection/Utils.hs +192/−0
- src/Collection/View.hs +0/−164
- src/Context.hs +6/−1
- src/Control/Concurrent/Makefile.in +1/−0
- src/Control/Concurrent/STM/Makefile.in +1/−0
- src/Control/Concurrent/STM/TGVar.hs +64/−0
- src/Control/Concurrent/STM/TWatch.hs +55/−0
- src/Control/Concurrent/STM/Watch.hs +31/−0
- src/Control/Makefile.in +1/−0
- src/Control/Monad/EnvIO.hs +100/−0
- src/Control/Monad/Makefile.in +1/−0
- src/Control/Monad/ToIO.hs +40/−0
- src/Control/Monad/W.hs +37/−0
- src/Data/Env.hs +74/−0
- src/Data/Makefile.in +1/−0
- src/Handler.hs +0/−78
- src/Index.hs +26/−12
- src/Location/Control.hs +7/−10
- src/Location/Model.hs +37/−40
- src/Location/PathComp.hs +90/−0
- src/Location/UI.hs +22/−10
- src/Location/View.hs +39/−3
- src/Medialib.hs +135/−86
- src/Playback.hs +37/−56
- src/Playlist.hs +11/−10
- src/Playlist/Edit.hs +20/−24
- src/Playlist/Format.hs +18/−10
- src/Playlist/Format/Config.hs +1/−0
- src/Playlist/Index.hs +24/−13
- src/Playlist/Model.hs +17/−26
- src/Playlist/Search.hs +2/−1
- src/Playlist/UI.hs +143/−110
- src/Playlist/Update.hs +46/−59
- src/Playlist/View.hs +25/−13
- src/Playtime.hs +187/−125
- src/Properties.hs +1/−1
- src/Properties/Editor/Model.hs +17/−8
- src/Properties/Editor/UI.hs +10/−4
- src/Properties/Impex.hs +2/−2
- src/Properties/Manager.hs +5/−3
- src/Properties/Model.hs +17/−17
- src/Properties/Order.hs +1/−0
- src/Properties/View.hs +2/−2
- src/Registry.hs +92/−0
- src/UI.hs +43/−5
- src/Utils.hs +3/−15
- src/Vision.hs +28/−27
- src/Volume.hs +50/−43
- src/XMMS.hs +25/−35
- ui/collection-browser.glade +35/−119
- ui/location-browser.glade +7/−0
- ui/playlist.glade +8/−1
- vision.cabal +36/−20
configure view
@@ -1,11 +1,11 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles.-# Generated by GNU Autoconf 2.65.+# Generated by GNU Autoconf 2.68. # # # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,-# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation,-# Inc.+# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software+# Foundation, Inc. # # # This configure script is free software; the Free Software Foundation@@ -89,6 +89,7 @@ IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator.+as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR@@ -213,11 +214,18 @@ # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables.+ # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV export CONFIG_SHELL- exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"}+ case $- in # ((((+ *v*x* | *x*v* ) as_opts=-vx ;;+ *v* ) as_opts=-v ;;+ *x* ) as_opts=-x ;;+ * ) as_opts= ;;+ esac+ exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"} fi if test x$as_have_required = xno; then :@@ -315,7 +323,7 @@ test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs"- } || test -d "$as_dir" || as_fn_error "cannot create directory $as_dir"+ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p@@ -355,19 +363,19 @@ fi # as_fn_arith -# as_fn_error ERROR [LINENO LOG_FD]-# ---------------------------------+# as_fn_error STATUS ERROR [LINENO LOG_FD]+# ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the-# script with status $?, using 1 if that was 0.+# script with STATUS, using 1 if that was 0. as_fn_error () {- as_status=$?; test $as_status -eq 0 && as_status=1- if test "$3"; then- as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack- $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3+ as_status=$1; test $as_status -eq 0 && as_status=1+ if test "$4"; then+ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi- $as_echo "$as_me: error: $1" >&2+ $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error @@ -529,7 +537,7 @@ exec 6>&1 # Name of the host.-# hostname on some systems (SVR3.2, Linux) returns a bogus exit status,+# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` @@ -665,8 +673,9 @@ fi case $ac_option in- *=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;- *) ac_optarg=yes ;;+ *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;+ *=) ac_optarg= ;;+ *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos.@@ -711,7 +720,7 @@ ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&- as_fn_error "invalid feature name: $ac_useropt"+ as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in@@ -737,7 +746,7 @@ ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&- as_fn_error "invalid feature name: $ac_useropt"+ as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in@@ -941,7 +950,7 @@ ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&- as_fn_error "invalid package name: $ac_useropt"+ as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in@@ -957,7 +966,7 @@ ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&- as_fn_error "invalid package name: $ac_useropt"+ as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in@@ -987,8 +996,8 @@ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; - -*) as_fn_error "unrecognized option: \`$ac_option'-Try \`$0 --help' for more information."+ -*) as_fn_error $? "unrecognized option: \`$ac_option'+Try \`$0 --help' for more information" ;; *=*)@@ -996,7 +1005,7 @@ # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* )- as_fn_error "invalid variable name: \`$ac_envvar'" ;;+ as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;;@@ -1006,7 +1015,7 @@ $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2- : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}+ : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac@@ -1014,13 +1023,13 @@ if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'`- as_fn_error "missing argument to $ac_option"+ as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;;- fatal) as_fn_error "unrecognized options: $ac_unrecognized_opts" ;;+ fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi@@ -1043,7 +1052,7 @@ [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac- as_fn_error "expected an absolute directory name for --$ac_var: $ac_val"+ as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host'@@ -1057,8 +1066,8 @@ if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe- $as_echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host.- If a cross compiler is detected then cross compile mode will be used." >&2+ $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host.+ If a cross compiler is detected then cross compile mode will be used" >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi@@ -1073,9 +1082,9 @@ ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` ||- as_fn_error "working directory cannot be determined"+ as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||- as_fn_error "pwd does not report name of working directory"+ as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified.@@ -1114,11 +1123,11 @@ fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."- as_fn_error "cannot find sources ($ac_unique_file) in $srcdir"+ as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`(- cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error "$ac_msg"+ cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then@@ -1158,7 +1167,7 @@ --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit- -q, --quiet, --silent do not print \`checking...' messages+ -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files@@ -1276,9 +1285,9 @@ if $ac_init_version; then cat <<\_ACEOF configure-generated by GNU Autoconf 2.65+generated by GNU Autoconf 2.68 -Copyright (C) 2009 Free Software Foundation, Inc.+Copyright (C) 2010 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF@@ -1293,7 +1302,7 @@ running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was-generated by GNU Autoconf 2.65. Invocation command line was+generated by GNU Autoconf 2.68. Invocation command line was $ $0 $@ @@ -1403,11 +1412,9 @@ { echo - cat <<\_ASBOX-## ---------------- ##+ $as_echo "## ---------------- ## ## Cache variables. ##-## ---------------- ##-_ASBOX+## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, (@@ -1441,11 +1448,9 @@ ) echo - cat <<\_ASBOX-## ----------------- ##+ $as_echo "## ----------------- ## ## Output variables. ##-## ----------------- ##-_ASBOX+## ----------------- ##" echo for ac_var in $ac_subst_vars do@@ -1458,11 +1463,9 @@ echo if test -n "$ac_subst_files"; then- cat <<\_ASBOX-## ------------------- ##+ $as_echo "## ------------------- ## ## File substitutions. ##-## ------------------- ##-_ASBOX+## ------------------- ##" echo for ac_var in $ac_subst_files do@@ -1476,11 +1479,9 @@ fi if test -s confdefs.h; then- cat <<\_ASBOX-## ----------- ##+ $as_echo "## ----------- ## ## confdefs.h. ##-## ----------- ##-_ASBOX+## ----------- ##" echo cat confdefs.h echo@@ -1535,7 +1536,12 @@ ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then- ac_site_file1=$CONFIG_SITE+ # We do not want a PATH search for config.site.+ case $CONFIG_SITE in #((+ -*) ac_site_file1=./$CONFIG_SITE;;+ */*) ac_site_file1=$CONFIG_SITE;;+ *) ac_site_file1=./$CONFIG_SITE;;+ esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site@@ -1550,7 +1556,11 @@ { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5- . "$ac_site_file"+ . "$ac_site_file" \+ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}+as_fn_error $? "failed to load site script $ac_site_file+See \`config.log' for more details" "$LINENO" 5; } fi done @@ -1626,7 +1636,7 @@ $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;}- as_fn_error "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5+ as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ##@@ -1648,7 +1658,7 @@ fi -ac_config_files="$ac_config_files Makefile ui/Makefile src/Makefile src/Properties/Makefile src/Properties/Editor/Makefile src/Playlist/Makefile src/Playlist/Format/Makefile src/Location/Makefile src/Collection/Makefile src/Collection/List/Makefile"+ac_config_files="$ac_config_files Makefile ui/Makefile src/Makefile src/Properties/Makefile src/Properties/Editor/Makefile src/Playlist/Makefile src/Playlist/Format/Makefile src/Location/Makefile src/Collection/Makefile src/Collection/List/Makefile src/Control/Makefile src/Control/Concurrent/Makefile src/Control/Concurrent/STM/Makefile src/Control/Monad/Makefile src/Data/Makefile" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure@@ -1714,10 +1724,21 @@ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then- test "x$cache_file" != "x/dev/null" &&+ if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;}- cat confcache >$cache_file+ if test ! -f "$cache_file" || test -h "$cache_file"; then+ cat confcache >"$cache_file"+ else+ case $cache_file in #(+ */* | ?:*)+ mv -f confcache "$cache_file"$$ &&+ mv -f "$cache_file"$$ "$cache_file" ;; #(+ *)+ mv -f confcache "$cache_file" ;;+ esac+ fi+ fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;}@@ -1769,6 +1790,7 @@ ac_libobjs= ac_ltlibobjs=+U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'@@ -1784,7 +1806,7 @@ -: ${CONFIG_STATUS=./config.status}+: "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS"@@ -1885,6 +1907,7 @@ IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator.+as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR@@ -1930,19 +1953,19 @@ (unset CDPATH) >/dev/null 2>&1 && unset CDPATH -# as_fn_error ERROR [LINENO LOG_FD]-# ---------------------------------+# as_fn_error STATUS ERROR [LINENO LOG_FD]+# ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the-# script with status $?, using 1 if that was 0.+# script with STATUS, using 1 if that was 0. as_fn_error () {- as_status=$?; test $as_status -eq 0 && as_status=1- if test "$3"; then- as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack- $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3+ as_status=$1; test $as_status -eq 0 && as_status=1+ if test "$4"; then+ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi- $as_echo "$as_me: error: $1" >&2+ $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error @@ -2138,7 +2161,7 @@ test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs"- } || test -d "$as_dir" || as_fn_error "cannot create directory $as_dir"+ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p@@ -2192,7 +2215,7 @@ # values after options handling. ac_log=" This file was extended by $as_me, which was-generated by GNU Autoconf 2.65. Invocation command line was+generated by GNU Autoconf 2.68. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS@@ -2245,10 +2268,10 @@ ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ config.status-configured by $0, generated by GNU Autoconf 2.65,+configured by $0, generated by GNU Autoconf 2.68, with options \\"\$ac_cs_config\\" -Copyright (C) 2009 Free Software Foundation, Inc.+Copyright (C) 2010 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." @@ -2263,11 +2286,16 @@ while test $# != 0 do case $1 in- --*=*)+ --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;;+ --*=)+ ac_option=`expr "X$1" : 'X\([^=]*\)='`+ ac_optarg=+ ac_shift=:+ ;; *) ac_option=$1 ac_optarg=$2@@ -2289,6 +2317,7 @@ $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;;+ '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;;@@ -2299,7 +2328,7 @@ ac_cs_silent=: ;; # This is an error.- -*) as_fn_error "unrecognized option: \`$1'+ -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1"@@ -2358,8 +2387,13 @@ "src/Location/Makefile") CONFIG_FILES="$CONFIG_FILES src/Location/Makefile" ;; "src/Collection/Makefile") CONFIG_FILES="$CONFIG_FILES src/Collection/Makefile" ;; "src/Collection/List/Makefile") CONFIG_FILES="$CONFIG_FILES src/Collection/List/Makefile" ;;+ "src/Control/Makefile") CONFIG_FILES="$CONFIG_FILES src/Control/Makefile" ;;+ "src/Control/Concurrent/Makefile") CONFIG_FILES="$CONFIG_FILES src/Control/Concurrent/Makefile" ;;+ "src/Control/Concurrent/STM/Makefile") CONFIG_FILES="$CONFIG_FILES src/Control/Concurrent/STM/Makefile" ;;+ "src/Control/Monad/Makefile") CONFIG_FILES="$CONFIG_FILES src/Control/Monad/Makefile" ;;+ "src/Data/Makefile") CONFIG_FILES="$CONFIG_FILES src/Data/Makefile" ;; - *) as_fn_error "invalid argument: \`$ac_config_target'" "$LINENO" 5;;+ *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done @@ -2380,9 +2414,10 @@ # after its creation but before its name has been assigned to `$tmp'. $debug || {- tmp=+ tmp= ac_tmp= trap 'exit_status=$?- { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status+ : "${ac_tmp:=$tmp}"+ { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 }@@ -2390,12 +2425,13 @@ { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&- test -n "$tmp" && test -d "$tmp"+ test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp")-} || as_fn_error "cannot create a temporary directory in ." "$LINENO" 5+} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5+ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES.@@ -2412,12 +2448,12 @@ fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' </dev/null 2>/dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then- ac_cs_awk_cr='\r'+ ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi -echo 'BEGIN {' >"$tmp/subs1.awk" &&+echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF @@ -2426,18 +2462,18 @@ echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh ||- as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5-ac_delim_num=`echo "$ac_subst_vars" | grep -c '$'`+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5+ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh ||- as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then- as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi@@ -2445,7 +2481,7 @@ rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-cat >>"\$tmp/subs1.awk" <<\\_ACAWK &&+cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h@@ -2493,7 +2529,7 @@ rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK-cat >>"\$tmp/subs1.awk" <<_ACAWK &&+cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" @@ -2525,21 +2561,29 @@ sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat-fi < "$tmp/subs1.awk" > "$tmp/subs.awk" \- || as_fn_error "could not setup config files machinery" "$LINENO" 5+fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \+ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF -# VPATH may cause trouble with some makes, so we remove $(srcdir),-# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and+# VPATH may cause trouble with some makes, so we remove sole $(srcdir),+# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then- ac_vpsub='/^[ ]*VPATH[ ]*=/{-s/:*\$(srcdir):*/:/-s/:*\${srcdir}:*/:/-s/:*@srcdir@:*/:/-s/^\([^=]*=[ ]*\):*/\1/+ ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{+h+s///+s/^/:/+s/[ ]*$/:/+s/:\$(srcdir):/:/g+s/:\${srcdir}:/:/g+s/:@srcdir@:/:/g+s/^:*// s/:*$//+x+s/\(=[ ]*\).*/\1/+G+s/\n// s/^[^=]*=[ ]*$// }' fi@@ -2557,7 +2601,7 @@ esac case $ac_mode$ac_tag in :[FHL]*:*);;- :L* | :C*:*) as_fn_error "invalid tag \`$ac_tag'" "$LINENO" 5;;+ :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac@@ -2576,7 +2620,7 @@ for ac_f do case $ac_f in- -) ac_f="$tmp/stdin";;+ -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'.@@ -2585,7 +2629,7 @@ [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac ||- as_fn_error "cannot find input file: \`$ac_f'" "$LINENO" 5;;+ as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'"@@ -2611,8 +2655,8 @@ esac case $ac_tag in- *:-:* | *:-) cat >"$tmp/stdin" \- || as_fn_error "could not create $ac_file" "$LINENO" 5 ;;+ *:-:* | *:-) cat >"$ac_tmp/stdin" \+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac@@ -2737,23 +2781,24 @@ s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack "-eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$tmp/subs.awk" >$tmp/out \- || as_fn_error "could not create $ac_file" "$LINENO" 5+eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \+ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&- { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } &&- { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } &&+ { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } &&+ { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \+ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir'-which seems to be undefined. Please make sure it is defined." >&5+which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'-which seems to be undefined. Please make sure it is defined." >&2;}+which seems to be undefined. Please make sure it is defined" >&2;} - rm -f "$tmp/stdin"+ rm -f "$ac_tmp/stdin" case $ac_file in- -) cat "$tmp/out" && rm -f "$tmp/out";;- *) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";;+ -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";;+ *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \- || as_fn_error "could not create $ac_file" "$LINENO" 5+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; @@ -2768,7 +2813,7 @@ ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 ||- as_fn_error "write failure creating $CONFIG_STATUS" "$LINENO" 5+ as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status.@@ -2789,7 +2834,7 @@ exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction.- $ac_cs_success || as_fn_exit $?+ $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5
configure.ac view
@@ -12,5 +12,10 @@ src/Playlist/Format/Makefile src/Location/Makefile src/Collection/Makefile- src/Collection/List/Makefile)+ src/Collection/List/Makefile+ src/Control/Makefile+ src/Control/Concurrent/Makefile+ src/Control/Concurrent/STM/Makefile+ src/Control/Monad/Makefile+ src/Data/Makefile) AC_OUTPUT
src/About.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 6 Sep. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -55,7 +55,7 @@ aboutDialogSetName about "Vision" aboutDialogSetVersion about $ showVersion version aboutDialogSetComments about "An XMMS2 client."- aboutDialogSetCopyright about "Copyright © 2010 Oleg Belozeorov."+ aboutDialogSetCopyright about "Copyright © 2010-2011 Oleg Belozeorov." aboutDialogSetLicense about $ Just license aboutDialogSetWrapLicense about True aboutDialogSetAuthors about authors
src/Clipboard.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 26 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -17,76 +17,83 @@ -- General Public License for more details. -- +{-# LANGUAGE DeriveDataTypeable, UndecidableInstances #-}+ module Clipboard ( initClipboard+ , clipboardEnv , clipboard- , onClipboardTargets+ , clipboardTargets , getClipboardTargets+ , copyIds ) where -import Control.Concurrent.MVar-import Control.Monad+import Control.Concurrent.STM+import Control.Monad.Trans+import Control.Monad.ToIO+import Control.Monad.EnvIO+import Control.Monad.W import Data.Maybe+import Data.Typeable+import Data.Env hiding (Env) -import Graphics.UI.Gtk hiding (Clipboard)-import qualified Graphics.UI.Gtk as G+import Graphics.UI.Gtk -import Context-import Handler-import Utils+import Registry+import Atoms (xmms2MlibIdTarget) -data State- = State { sTargets :: [TargetTag] }--makeState =- State { sTargets = [] }+data Ix = Ix deriving (Typeable) -data Clipboard- = Clipboard { cState :: MVar State- , cClipboard :: G.Clipboard- , cOnClipboardTargets :: HandlerMVar ()- }+data Env+ = Env { cTargets :: TVar [TargetTag]+ , cClipboard :: Clipboard+ }+ deriving (Typeable) -state = cState context+clipboardEnv :: Extract Ix Env+clipboardEnv = Extract -clipboard = cClipboard context+clipboard = envsx Ix cClipboard+clipboardTargets = envsx Ix cTargets -onClipboardTargets = onHandler $ cOnClipboardTargets context+getClipboardTargets =+ clipboardTargets >>= liftIO . readTVarIO -getClipboardTargets = withMVar state $ return . sTargets+copyIds ids = do+ clipboard <- clipboard+ liftIO $ do+ clipboardSetWithData clipboard+ [(xmms2MlibIdTarget, 0)]+ (const $ selectionDataSet selectionTypeInteger ids)+ (return ())+ return () -updateClipboardTargets targets = do- let targets' = fromMaybe [] targets- modifyMVar state $ \state ->- return (state { sTargets = targets' }, sTargets state /= targets')+updateClipboardTargets ts = do+ targets <- clipboardTargets+ liftIO $ atomically $ writeTVar targets $ fromMaybe [] ts initClipboard = do- context <- initContext- let ?context = context-- timeoutAdd checkClipboard 0-- return ?context-+ env <- makeEnv+ addEnv Ix env+ runIn (mkEnv Ix env) $> do+ io $ \run -> timeoutAdd (run checkClipboard) 0+ return () -initContext = do- state <- newMVar makeState+makeEnv = liftIO $ do+ targets <- newTVarIO [] clipboard <- clipboardGet selectionClipboard- onClipboardTargets <- makeHandlerMVar- return $ augmentContext- Clipboard { cState = state- , cClipboard = clipboard- , cOnClipboardTargets = onClipboardTargets- }+ return Env { cTargets = targets+ , cClipboard = clipboard+ } checkClipboard = do- clipboard <- clipboardGet selectionClipboard- clipboardRequestTargets clipboard $ \targets -> do- changed <- updateClipboardTargets targets- when changed $ onClipboardTargets $ invoke ()- timeoutAdd checkClipboard 250- return ()+ cb <- clipboard+ io $ \run ->+ clipboardRequestTargets cb $ \targets -> run $ do+ updateClipboardTargets targets+ liftIO $ timeoutAdd (run checkClipboard) 250+ return () return False
src/Collection.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 14 Jul. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -22,46 +22,70 @@ , browseCollection ) where -import Graphics.UI.Gtk+import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TGVar +import Control.Monad+import Control.Monad.ToIO+import Control.Monad.Trans+import Control.Monad.W++import Graphics.UI.Gtk hiding (selectAll, focus)+ import UI+import Clipboard+import Registry+import XMMS+import Properties+ import Collection.Common import Collection.List-import Collection.Model-import Collection.View-import Collection.Control-import Collection.DnD-import Collection.UI+import Collection.Select+import Collection.Utils -initCollection = do- context <- initCommon- let ?context = context+initCollection =+ initList - context <- initList+browseCollection _maybeName = do+ builder <- liftIO $ makeBuilder "collection-browser"+ context <- liftIO $ initUI builder let ?context = context - return ?context---browseCollection maybeName = do- builder <- makeBuilder "collection-browser"+ env <- liftIO $ mkEnv builder - let f = browseCollection+ Just ce <- getEnv clipboardEnv+ runIn ce $> io $ \run -> bindActions builder $+ [ ("add-to-playlist", envWithColl env $ addToPlaylist False)+ , ("replace-playlist", envWithColl env $ addToPlaylist True)+ , ("select-all", envWithSel env selectAll)+ , ("invert-selection", envWithSel env invertSelection)+ , ("copy", envWithIds env (run . copyIds))+ , ("edit-properties", envWithIds env showPropertyEditor)+ , ("export-properties", envWithIds env showPropertyExport)+ , ("import-properties", showPropertyImport)+ , ("manage-properties", showPropertyManager)+ , ("save-collection", envWithColl env $ saveCollection)+ , ("rename-collection", envWithNames env $ renameCollection)+ , ("delete-collections", envWithNames env $ deleteCollections)+ ] - context <- initModel- let ?context = context+ liftIO $ do+ ag <- builderGetObject builder castToActionGroup "server-actions"+ xcW <- atomically $ newTGWatch connectedV+ tid <- forkIO $ forever $ do+ conn <- atomically $ watch xcW+ postGUISync $ actionGroupSetSensitive ag conn+ window `onDestroy` (killThread tid) - context <- initView builder- let ?context = context+ lv <- mkListView env+ liftIO $ do+ box <- builderGetObject builder castToVBox "views"+ boxPackStartDefaults box $ eScroll env - context <- initUI builder- let ?context = context+ addView env lv+ onCollBuilt env lv $ mkSelect env - setupUI builder f- setupDnD+ widgetShowAll window - widgetShowAll window- case maybeName of- Just name -> loadNamed name- Nothing -> widgetGrabFocus collFilter
+ src/Collection/Actions.hs view
@@ -0,0 +1,47 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 6 Jul. 2011+--+-- Copyright (C) 2011 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.Actions+ ( ActionBackend (..)+ , ActionEnabler (..)+ , emptyAB+ ) where++import Graphics.UI.Gtk++import XMMS2.Client+++data ActionBackend+ = AB { aWithColl :: (Coll -> IO ()) -> IO ()+ , aWithNames :: ([String] -> IO ()) -> IO ()+ , aSelection :: Maybe TreeSelection+ }++emptyAB =+ AB { aWithColl = const $ return ()+ , aWithNames = const $ return ()+ , aSelection = Nothing+ }++data ActionEnabler+ = AE { aEnableSel :: Bool -> IO ()+ , aEnableRen :: Bool -> IO ()+ , aEnableDel :: Bool -> IO ()+ }
+ src/Collection/Combo.hs view
@@ -0,0 +1,62 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 6 Jul. 2011+--+-- Copyright (C) 2011 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.Combo+ ( mkCombo+ , ComboItem (..)+ ) where++import Data.IORef++import Graphics.UI.Gtk++import Properties.Property++import Collection.Actions+import Collection.Common+import Collection.ComboModel+++mkCombo env = do+ let abRef = eABRef env+ ae = eAE env+ cmodel = eCModel env++ combo <- comboBoxNewWithModel cmodel+ comboBoxSetRowSeparatorSource combo $ Just (cmodel, separator)++ cell <- cellRendererTextNew+ cellLayoutPackStart combo cell True+ cellLayoutSetAttributes combo cell cmodel $ \p ->+ case p of+ CITracks -> [ cellText := "Tracks" ]+ CIProp p -> [ cellText := propName p ]+ CISeparator -> []++ combo `on` setFocusChild $ \fc -> do+ maybe (return ()) (const $ writeIORef abRef emptyAB) fc+ aEnableSel ae False+ aEnableRen ae False+ aEnableDel ae False++ return combo++separator CISeparator = True+separator _ = False+
+ src/Collection/ComboModel.hs view
@@ -0,0 +1,41 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 8 Jul. 2011+--+-- Copyright (C) 2011 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.ComboModel+ ( mkModel+ , ComboItem (..)+ ) where++import Graphics.UI.Gtk++import Properties.Model+import Properties.Property+++data ComboItem+ = CIProp Property+ | CITracks+ | CISeparator++mkModel = do+ props <- getProperties+ store <- listStoreNewDND (map CIProp props) Nothing Nothing+ listStoreAppend store CISeparator+ listStoreAppend store CITracks+ return store
src/Collection/Common.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 14 Jul. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -18,22 +18,121 @@ -- module Collection.Common- ( initCommon- , universe+ ( Env (..)+ , mkEnv+ , envWithColl+ , envWithIds+ , envWithSel+ , envWithNames+ , addView+ , FocusChild (..) ) where +import Control.Monad+import Control.Monad.Trans++import Data.IORef++import Graphics.UI.Gtk hiding (focus)+ import XMMS2.Client -import Context+import UI+import Utils+import XMMS+import Compound +import Collection.Actions+import Collection.ScrollBox+import Collection.ComboModel -data Common- = Common { cUniverse :: Coll } -universe = cUniverse context+data Env+ = Env { eABRef :: IORef ActionBackend+ , eAE :: ActionEnabler+ , eSBox :: ScrollBox+ , eLPopup :: Menu+ , eVPopup :: Menu+ , eCModel :: ListStore ComboItem+ , eScroll :: ScrolledWindow+ , eSAdj :: Adjustment+ } +mkEnv builder = do+ abRef <- newIORef emptyAB+ selActs <- mapM (action builder)+ [ "add-to-playlist"+ , "replace-playlist"+ , "copy"+ , "edit-properties"+ , "export-properties"+ , "save-collection"+ ]+ renAct <- action builder "rename-collection"+ delAct <- action builder "delete-collections"+ let ae = AE { aEnableSel = \en -> mapM_ (`actionSetSensitive` en) selActs+ , aEnableRen = actionSetSensitive renAct+ , aEnableDel = actionSetSensitive delAct+ }+ sbox <- mkScrollBox+ lpopup <- liftIO $ getWidget castToMenu "ui/list-popup"+ vpopup <- liftIO $ getWidget castToMenu "ui/view-popup"+ cmodel <- mkModel -initCommon = do- universe <- collUniverse- return $ augmentContext- Common { cUniverse = universe }+ scroll <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scroll ShadowNone+ scrolledWindowSetPolicy scroll PolicyAutomatic PolicyNever+ adj <- scrolledWindowGetHAdjustment scroll++ fcRef <- newIORef Nothing++ let scrollIn mfc = void $ withJust mfc $ \fc ->+ flip idleAdd priorityLow $ do+ Rectangle x _ w _ <- widgetGetAllocation fc+ adjustmentClampPage adj (fromIntegral x) (fromIntegral (x + w))+ return False++ adj `afterAdjChanged` do+ mfc <- readIORef fcRef+ scrollIn mfc++ (sBox sbox) `on` setFocusChild $ \mfc -> do+ writeIORef fcRef mfc+ scrollIn mfc++ containerAdd scroll $ outer sbox++ return Env { eABRef = abRef+ , eAE = ae+ , eSBox = sbox+ , eLPopup = lpopup+ , eVPopup = vpopup+ , eCModel = cmodel+ , eScroll = scroll+ , eSAdj = adj+ }++envWithColl env f = do+ ab <- readIORef $ eABRef env+ aWithColl ab f++envWithIds env f = envWithColl env $ \coll ->+ collQueryIds xmms coll [] 0 0 >>* do+ ids <- result+ liftIO $ f ids++envWithSel env f = do+ ab <- readIORef $ eABRef env+ withJust (aSelection ab) f++envWithNames env f = do+ ab <- readIORef $ eABRef env+ aWithNames ab f++addView env w = do+ scrollBoxAdd (eSBox env) $ outer w+ widgetGrabFocus $ focus w++class FocusChild f where+ type Focus f+ focus :: f -> Focus f
− src/Collection/Control.hs
@@ -1,264 +0,0 @@--- -*-haskell-*---- Vision (for the Voice): an XMMS2 client.------ Author: Oleg Belozeorov--- Created: 20 Jul. 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.Control- ( loadSelected- , loadNamed- , loadCurrent- , browseSelected- , addToPlaylist- , collAddToPlaylist- , listAddToPlaylist- , applyFilter- , editFilter- , allMedia- , saveCollection- , renameCollection- , removeCollection- , updateWindowTitle- , editCopy- , editSelectAll- , editInvertSelection- , showPropertyEditor- , showPropertyExport- , getOrder- , setOrder- , getSelectedIds- ) where--import Prelude hiding (catch)-import Control.Monad.CatchIO-import Control.Monad-import Control.Monad.Trans-import Control.Applicative--import Data.Maybe--import Graphics.UI.Gtk--import XMMS2.Client--import XMMS-import Utils-import UI-import Atoms-import Clipboard-import qualified Properties as P-import Collection.Common-import Collection.Model hiding (setOrder)-import qualified Collection.Model as Model-import Collection.View-import Collection.List.View---loadSelected = do- maybeName <- getSelectedCollection- case maybeName of- Just name ->- loadNamed name- Nothing -> do- setCurColl universe ""- loadCurrent--loadNamed name =- collGet xmms name "Collections" >>* do- coll <- result- liftIO $ do- setCurColl coll name- loadCurrent--setOrder order = do- Model.setOrder True order- loaded <- getLoaded- when loaded loadCurrent--loadCurrent =- loadCurrent' `catch` \ParseError -> return ()--loadCurrent' = do- text <- trim <$> entryGetText collFilter- entrySetText collFilter text- setFilter text- coll <- getCurColl- keys <- getOrderKeys- collQueryIds xmms coll keys 0 0 >>* do- ids <- result- liftIO $ do- setLoaded True- updateWindowTitle- populateModel ids- widgetGrabFocus collView--browseSelected browse =- browse =<< getSelectedCollection---addToPlaylist replace = do- list <- widgetGetIsFocus listView- if list- then listAddToPlaylist replace- else do- coll <- widgetGetIsFocus collView- when coll $ collAddToPlaylist replace--collAddToPlaylist replace =- add `catch` \ParseError -> return ()- where add = do- ids <- getSelectedIds- cur <- getCurColl- sel <- collNewIdlist ids- int <- collNew TypeIntersection- collAddOperand int cur- collAddOperand int sel- addCollection replace int--listAddToPlaylist replace = do- maybeName <- getSelectedCollection- case maybeName of- Nothing -> addCollection replace universe- Just name -> collGet xmms name "Collections" >>* do- coll <- result- liftIO $ addCollection replace coll--addCollection replace coll = do- when replace $ playlistClear xmms Nothing >> return ()- playlistAddCollection xmms Nothing coll =<< getOrderKeys- return ()--getSelectedIds =- mapM (listStoreGetValue collStore . head)- =<< treeSelectionGetSelectedRows collSel--applyFilter = do- conn <- connected- when conn loadSelected--editFilter = do- editableSelectRegion collFilter 0 (-1)- widgetGrabFocus collFilter--allMedia = do- resetModel- resetListView- entrySetText collFilter ""- widgetGrabFocus collFilter- updateWindowTitle--saveCollection = do- name <- trim <$> getCurName- coll <- getCurColl- res <- runDlg "Save collection" (not $ null name) (const True) name- withJust res $ \name -> do- collSave xmms coll name "Collections"- return ()--renameCollection = do- old <- fromJust <$> getSelectedCollection- res <- runDlg "Rename collection" False (/= old) old- withJust res $ \new -> do- collRename xmms old new "Collections"- return ()--removeCollection = do- name <- fromJust <$> getSelectedCollection- collRemove xmms name "Collections"- return ()--runDlg title enable isOk init = do- dialog <- dialogNew- windowSetTitle dialog title- windowSetTransientFor dialog window- windowSetModal dialog True- windowGroupAddWindow windowGroup dialog-- dialogSetHasSeparator dialog False- dialogAddButton dialog "gtk-cancel" ResponseCancel- dialogAddButtonCR dialog "gtk-ok" ResponseOk- dialogSetDefaultResponse dialog ResponseOk- dialogSetResponseSensitive dialog ResponseOk enable-- box <- vBoxNew False 0- containerSetBorderWidth box 7- upper <- dialogGetUpper dialog- containerAdd upper box-- entry <- entryNew- entrySetText entry init- editableSelectRegion entry 0 (-1)- editableSetPosition entry (-1)- boxPackStart box entry PackNatural 0-- let ok = do- new <- trim <$> entryGetText entry- return $ not (null new) && isOk new- check = dialogSetResponseSensitive dialog ResponseOk =<< ok- checkInsert str pos = check >> return (length str + pos)- checkDelete _ _ = check- entry `onEntryActivate` do- ok <- ok- when ok $ dialogResponse dialog ResponseOk- entry `afterInsertText` checkInsert- entry `afterDeleteText` checkDelete-- widgetShowAll dialog- resp <- dialogRun dialog- new <- trim <$> entryGetText entry- widgetDestroy dialog-- return $ case resp of- ResponseOk -> Just new- _ -> Nothing--updateWindowTitle = do- name <- getCurName- loaded <- getLoaded- filter <- getFilter- let t = if loaded then f ++ n ++ " - " else ""- n = case name of- "" -> "All media"- _ -> name- f = if null filter then "" else "*"- setWindowTitle $ t ++ "Vision collection browser"--editCopy = do- ids <- getSelectedIds- clipboardSetWithData clipboard- [(xmms2MlibIdTarget, 0)]- (const $ selectionDataSet selectionTypeInteger ids)- (return ())- return ()--editSelectAll =- treeSelectionSelectAll collSel--editInvertSelection = do- rows <- treeSelectionGetSelectedRows collSel- treeSelectionSelectAll collSel- mapM_ (treeSelectionUnselectPath collSel) rows---showPropertyEditor = withSelectedIds P.showPropertyEditor--showPropertyExport = withSelectedIds P.showPropertyExport--withSelectedIds f =- f =<< getSelectedIds--getOrderKeys =- P.encodeOrder <$> getOrder
− src/Collection/DnD.hs
@@ -1,47 +0,0 @@--- -*-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/List.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 20 Jul. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -19,13 +19,11 @@ module Collection.List ( initList- , listStore- , initListView- , listView+ , module Collection.List.View ) where import Collection.List.Model import Collection.List.View -initList = initListModel+initList = initModel
src/Collection/List/Model.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 20 Jul. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -17,57 +17,84 @@ -- General Public License for more details. -- +{-# LANGUAGE DeriveDataTypeable #-}+ module Collection.List.Model- ( initListModel- , listStore+ ( initModel+ , store+ , modelEnv ) where import Control.Monad import Control.Monad.Trans+import Control.Monad.ToIO+import Control.Monad.EnvIO+import Control.Monad.W +import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TGVar++import Data.Typeable+import Data.Env+ import Graphics.UI.Gtk hiding (add) import XMMS2.Client -import Context+import Registry import XMMS-import Handler data Model- = Model { mStore :: ListStore (Maybe String) }+ = Model { mStore :: ListStore (Maybe (String, Coll)) }+ deriving (Typeable) -listStore = mStore context+data Ix = Ix deriving (Typeable) +modelEnv :: Extract Ix Model+modelEnv = Extract -initListModel = do- context <- initContext- let ?context = context+initModel = do+ model <- mkModel+ runIn (mkEnv Ix model) $> setupModel+ addEnv Ix model - onServerConnection . add . ever $ \conn ->- if conn- then do+mkModel = liftIO $ do+ store <- listStoreNewDND [] Nothing Nothing+ return Model { mStore = store }++setupModel = io $ \run -> do+ xcW <- atomically $ newTGWatch connectedV+ forkIO $ forever $ do+ conn <- atomically $ watch xcW+ postGUISync $ run clearStore+ when conn $ do broadcastCollectionChanged xmms >>* do change <- result when (namespace change == "Collections") $- -- TODO: use the change info instead of repopulating the model.- liftIO listCollections+ liftIO $ run listCollections persist- listCollections- else- listStoreClear listStore+ run listCollections - return ?context+listCollections = io $ \run ->+ collList xmms "Collections" >>* do+ names <- result+ liftIO $ run $ do+ clearStore+ fillStore names -initContext = do- store <- listStoreNewDND [] Nothing Nothing- return $ augmentContext- Model { mStore = store }+store = envsx Ix mStore -listCollections =- collList xmms "Collections" >>* do- colls <- result- liftIO $ do- listStoreClear listStore- listStoreAppend listStore Nothing- mapM_ (listStoreAppend listStore . Just) colls+clearStore = do+ store <- store+ liftIO $ listStoreClear store++fillStore names = do+ store <- store+ liftIO $ do+ listStoreAppend store Nothing+ forM_ names $ \name ->+ collGet xmms name "Collections" >>* do+ coll <- result+ liftIO $ listStoreAppend store $ Just (name, coll)
src/Collection/List/View.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 10 Mar. 2010 ----- Copyright (C) 2009-2010 Oleg Belozeorov+-- Copyright (C) 2009-2011 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@@ -16,105 +16,150 @@ -- General Public License for more details. -- +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+ module Collection.List.View- ( initListView- , listView- , resetListView- , onCollectionActivated- , onCollectionSelectionChanged- , onCollectionListMidClick- , onCollectionListCR- , getSelectedCollection+ ( ListView (..)+ , mkListView ) where +import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TGVar+ import Control.Applicative+import Control.Monad import Control.Monad.Trans+import Control.Monad.EnvIO+import Control.Monad.W import Data.Char (toLower) import Data.List (isInfixOf)+import Data.IORef+import Data.Maybe import Graphics.UI.Gtk -import Context-import Collection.List.Model+import XMMS2.Client +import Registry+import XMMS+import Utils+import Compound -data View- = View { vView :: TreeView- , vSel :: TreeSelection- }+import Collection.Common+import Collection.List.Model+import Collection.Actions+import Collection.Utils -listView = vView context-listSel = vSel context +data ListView+ = V { vView :: TreeView+ , vSel :: TreeSelection+ , vNextRef :: IORef VI+ , vStore :: ListStore (Maybe (String, Coll))+ , vScroll :: ScrolledWindow+ } -initListView builder = do- context <- initContext builder- let ?context = context+mkListView env = do+ Just me <- getEnv modelEnv+ store <- runIn me $> store+ liftIO $ do+ let abRef = eABRef env+ ae = eAE env+ view <- treeViewNewWithModel store+ treeViewSetHeadersVisible view False+ treeViewSetRulesHint view True - treeSelectionSetMode listSel SelectionBrowse+ sel <- treeViewGetSelection view+ treeSelectionSetMode sel SelectionMultiple+ setupTreeViewPopup view $ eLPopup env - treeViewSetModel listView listStore+ scroll <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scroll ShadowIn+ scrolledWindowSetPolicy scroll PolicyNever PolicyAutomatic+ containerAdd scroll view - treeViewSetHeadersVisible listView False- widgetSetSizeRequest listView 200 (-1)+ column <- treeViewColumnNew+ treeViewAppendColumn view column+ cell <- cellRendererTextNew+ treeViewColumnPackStart column cell True+ cellLayoutSetAttributes column cell store $ \n ->+ case n of+ Nothing ->+ [ cellText := "All Media", cellTextWeight := 800 ]+ Just cn ->+ [ cellText := fst cn, cellTextWeightSet := False ] - column <- treeViewColumnNew- treeViewAppendColumn listView column- cell <- cellRendererTextNew- treeViewColumnPackStart column cell True- cellLayoutSetAttributes column cell listStore $ \n ->- case n of- Nothing ->- [ cellText := "All Media", cellTextWeight := 800 ]- Just cn ->- [ cellText := cn, cellTextWeightSet := False ]+ treeViewSetEnableSearch view True+ treeViewSetSearchEqualFunc view . Just $ \str iter ->+ maybe False (isInfixOf (map toLower str) . map toLower . fst) <$>+ (listStoreGetValue store $ listStoreIterToIndex iter) - treeViewSetEnableSearch listView True- treeViewSetSearchEqualFunc listView . Just $ \str iter ->- maybe False (isInfixOf (map toLower str) . map toLower) <$>- (listStoreGetValue listStore . head- =<< treeModelGetPath listStore iter)+ nextRef <- newIORef None - return ?context+ let v = V { vView = view+ , vSel = sel+ , vNextRef = nextRef+ , vStore = store+ , vScroll = scroll+ } -resetListView =- treeViewSetCursor listView [0] Nothing+ let aef = do+ foc <- view `get` widgetHasFocus+ when foc $ do+ rows <- treeSelectionGetSelectedRows sel+ aEnableSel ae $ not $ null rows+ aEnableDel ae $ case rows of+ [] -> False+ [0] : _ -> False+ _ -> True+ aEnableRen ae $ case rows of+ [[0]] -> False+ [_] -> True+ _ -> False+ setupViewFocus abRef view aef+ AB { aWithColl = withBuiltColl v+ , aWithNames = \f -> withColls v (f . map fst . catMaybes)+ , aSelection = Just sel+ }+ sel `on` treeSelectionSelectionChanged $ aef + xcW <- atomically $ newTGWatch connectedV+ tid <- forkIO $ forever $ do+ void $ atomically $ watch xcW+ postGUISync $ killNext v+ view `onDestroy` (killThread tid) -initContext builder = do- view <- builderGetObject builder castToTreeView "list-view"- sel <- treeViewGetSelection view- return $ augmentContext- View { vView = view- , vSel = sel- }+ widgetShowAll scroll+ return v -onCollectionActivated =- onRowActivated listView . const . const+instance CollBuilder ListView where+ withBuiltColl lv f = withColls lv $ withColl f+ treeViewSel lv = (vView lv, vSel lv) -onCollectionSelectionChanged =- onSelectionChanged listSel+withColls lv f = do+ let store = vStore lv+ sel = vSel lv+ rows <- treeSelectionGetSelectedRows sel+ unless (null rows) $ do+ colls <- mapM (listStoreGetValue store . head) rows+ f colls -onCollectionListMidClick f =- listView `on` buttonPressEvent $ tryEvent $ do- MiddleButton <- eventButton- SingleClick <- eventClick- (x, y) <- eventCoordinates- liftIO $ do- Just (p, _, _) <- treeViewGetPathAtPos listView (round x, round y)- treeViewSetCursor listView p Nothing- f+withColl _ [] = return ()+withColl f (Nothing : _) = f =<< collUniverse+withColl f list = do+ uni <- collNew TypeUnion+ mapM_ (collAddOperand uni . snd) $ catMaybes list+ f uni -onCollectionListCR f =- listView `on` keyPressEvent $ tryEvent $ do- [Control] <- eventModifier- "Return" <- eventKeyName- liftIO f+instance CompoundWidget ListView where+ type Outer ListView = ScrolledWindow+ outer = vScroll -getSelectedCollection = do- path <- fst <$> treeViewGetCursor listView- case path of- [n] -> listStoreGetValue listStore n- _ -> return Nothing+instance FocusChild ListView where+ type Focus ListView = TreeView+ focus = vView +instance ViewItem ListView where+ nextVIRef = vNextRef
− src/Collection/Model.hs
@@ -1,172 +0,0 @@--- -*-haskell-*---- Vision (for the Voice): an XMMS2 client.------ Author: Oleg Belozeorov--- Created: 14 Jul. 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.Model- ( initModel- , collStore- , getInfo- , populateModel- , getCurName- , getCurColl- , setCurColl- , getFilter- , setFilter- , resetModel- , getLoaded- , setLoaded- , getOrder- , setOrder- ) where--import Control.Applicative-import Control.Arrow-import Control.Monad-import Control.Concurrent.MVar--import Data.Maybe--import Graphics.UI.Gtk--import XMMS2.Client--import Context-import Index hiding (getInfo)-import qualified Index as Index-import Medialib hiding (getInfo)-import Collection.Common-import qualified Properties as P-import Config---data State- = State { sCurColl :: Coll- , sCurName :: String- , sFilter :: String- , sLoaded :: Bool- , sOrder :: [(P.Property, Bool)]- }--makeState =- State { sCurColl = universe- , sCurName = ""- , sFilter = ""- , sLoaded = False- , sOrder = []- }--data Model- = Model { mState :: MVar State- , mStore :: ListStore MediaId- , mIndex :: Index MediaInfo- }--state = mState context--collStore = mStore context-collIndex = mIndex context--getCurName =- withMVar state $ return . sCurName--getCurColl =- withMVar state $ \s ->- case sFilter s of- [] -> return $ sCurColl s- text -> do- fil <- collParse text- int <- collNew TypeIntersection- collAddOperand int $ sCurColl s- collAddOperand int fil- return int--setCurColl coll name =- modifyMVar_ state $ \s ->- return s { sCurColl = coll- , sCurName = name- }--getFilter = withMVar state $ return . sFilter--setFilter text =- modifyMVar_ state $ \s ->- return s { sFilter = text }--getLoaded =- withMVar state $ return . sLoaded--setLoaded loaded =- modifyMVar_ state $ \s ->- return s { sLoaded = loaded }--getOrder =- withMVar state $ return . sOrder--setOrder save o = do- modifyMVar_ state $ \s ->- return s { sOrder = o }- when save $ saveOrder o--getInfo = Index.getInfo (mIndex context)---initModel = do- context <- initContext- let ?context = context-- setOrder False =<< loadOrder-- return ?context---initContext = do- state <- newMVar makeState- store <- listStoreNewDND [] Nothing Nothing- index <- makeIndex store return- return $ augmentContext- Model { mState = state- , mStore = store- , mIndex = index- }--populateModel ids = do- clearIndex collIndex- listStoreClear collStore- mapM_ addOne ids- where addOne id = do- n <- listStoreAppend collStore id- addToIndex collIndex id n--resetModel = do- listStoreClear collStore- modifyMVar_ state . const $ return makeState---loadOrder =- catMaybes <$> (mapM convert =<< config configFile [])- where convert (name, desc) =- maybe Nothing (Just . (, desc)) <$> P.property name--saveOrder order = do- writeConfig configFile $ map (first P.propName) order- return ()--configFile =- "collection-order.conf"
+ src/Collection/PropFlt.hs view
@@ -0,0 +1,180 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 6 Jul. 2011+--+-- Copyright (C) 2011 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.PropFlt+ ( PropFlt (..)+ , mkPropFlt+ ) where++import Prelude hiding (lookup)++import Control.Applicative+import Control.Monad+import Control.Monad.Trans++import Data.List (intercalate, isInfixOf)+import Data.Char (toLower)+import Data.Map (lookup)+import Data.IORef++import Graphics.UI.Gtk++import XMMS2.Client hiding (Property)+import qualified XMMS2.Client as X++import Properties hiding (lookup)+import XMMS+import Utils+import Compound++import Collection.Common+import Collection.Actions+import Collection.Utils+++data PropFlt+ = PF { pStore :: ListStore X.Property+ , pView :: TreeView+ , pSel :: TreeSelection+ , pScroll :: ScrolledWindow+ , pColl :: Coll+ , pProp :: Property+ , pNextRef :: IORef VI+ }++instance ViewItem PropFlt where+ nextVIRef = pNextRef++mkPropFlt env prop coll = do+ let abRef = eABRef env+ ae = eAE env++ store <- listStoreNewDND [] Nothing Nothing+ view <- treeViewNewWithModel store+ treeViewSetHeadersVisible view False++ sel <- treeViewGetSelection view+ treeSelectionSetMode sel SelectionMultiple++ treeViewSetRulesHint view True+ setupTreeViewPopup view $ eVPopup env++ column <- treeViewColumnNew+ treeViewAppendColumn view column+ cell <- cellRendererTextNew+ treeViewColumnPackStart column cell True+ cellLayoutSetAttributes column cell store $ \p ->+ [ cellText := showValue prop p ]++ scroll <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scroll ShadowIn+ scrolledWindowSetPolicy scroll PolicyNever PolicyAutomatic+ containerAdd scroll view+ widgetShowAll scroll++ treeViewSetEnableSearch view True+ treeViewSetSearchEqualFunc view . Just $ \str iter ->+ (isInfixOf (map toLower str) . map toLower . showValue prop) <$>+ (listStoreGetValue store $ listStoreIterToIndex iter)++ fcoll <- collNew TypeIntersection+ collAddOperand fcoll coll+ flt <- collParse $ "NOT " ++ propKey prop ++ ":''"+ collAddOperand fcoll flt++ let key = propKey prop+ addLine v [] = return v+ addLine v (p : ps) =+ case lookup key p of+ Just s | v == s -> addLine v ps+ | otherwise -> do+ listStoreAppend store s+ addLine s ps+ Nothing -> addLine v ps+ getInfos s v =+ collQueryInfos xmms fcoll [key] s 100 [key] [key] >>* do+ lst <- result+ len <- resultLength+ liftIO $ do+ v' <- addLine v lst+ when (len == 100) $+ getInfos (s + 100) v'+ getInfos 0 (PropString "")++ nextRef <- newIORef None++ let pf = PF { pStore = store+ , pView = view+ , pSel = sel+ , pScroll = scroll+ , pColl = fcoll+ , pProp = prop+ , pNextRef = nextRef+ }+ aef = do+ foc <- view `get` widgetHasFocus+ when foc $ do+ rows <- treeSelectionGetSelectedRows sel+ aEnableSel ae $ not $ null rows+ aEnableRen ae False+ aEnableDel ae False+ setupViewFocus abRef view aef+ AB { aWithColl = withBuiltColl pf+ , aWithNames = const $ return ()+ , aSelection = Just sel+ }+ sel `on` treeSelectionSelectionChanged $ aef++ return pf++instance CollBuilder PropFlt where+ withBuiltColl pf f = do+ let store = pStore pf+ sel = pSel pf+ rows <- treeSelectionGetSelectedRows sel+ unless (null rows) $ do+ vals <- mapM (listStoreGetValue store . head) rows+ int <- collNew TypeIntersection+ collAddOperand int $ pColl pf+ flt <- collParse $ mkFilterText (pProp pf) vals+ collAddOperand int flt+ f int+ treeViewSel pf = (pView pf, pSel pf)++instance CompoundWidget PropFlt where+ type Outer PropFlt = ScrolledWindow+ outer = pScroll++instance FocusChild PropFlt where+ type Focus PropFlt = TreeView+ focus = pView+++cond' [] = "'"+cond' ('\'' : t) = '\\' : '\'' : cond' t+cond' ('\\' : t) = '\\' : '\\' : cond' t+cond' (h : t) = h : cond' t++cond prop (PropString s)+ | propKey prop == "url" = "url:'" ++ s ++ "'"+ | otherwise = propKey prop ++ ":'" ++ cond' s+cond prop (PropInt32 i) = propKey prop ++ ":" ++ show i++mkFilterText prop vals =+ intercalate " OR " $ map (cond prop) vals
+ src/Collection/ScrollBox.hs view
@@ -0,0 +1,53 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 5 Jul. 2011+--+-- Copyright (C) 2011 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.ScrollBox+ ( ScrollBox (..)+ , mkScrollBox+ , scrollBoxAdd+ ) where++import Graphics.UI.Gtk++import Compound+++data ScrollBox+ = SB { sBox :: HBox+ , sViewport :: Viewport+ }++mkScrollBox = do+ box <- hBoxNew False 5+ hAdj <- adjustmentNew 0 0 0 0 0 0+ vAdj <- adjustmentNew 0 0 0 0 0 0+ viewport <- viewportNew hAdj vAdj+ viewportSetShadowType viewport ShadowNone+ containerSetBorderWidth box 5+ containerAdd viewport box+ return SB { sBox = box+ , sViewport = viewport+ }++scrollBoxAdd sb widget =+ boxPackStart (sBox sb) widget PackNatural 0++instance CompoundWidget ScrollBox where+ type Outer ScrollBox = Viewport+ outer = sViewport
+ src/Collection/Select.hs view
@@ -0,0 +1,89 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 6 Jul. 2011+--+-- Copyright (C) 2011 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 NoMonoLocalBinds #-}++module Collection.Select+ ( Select (..)+ , mkSelect+ ) where++import Data.IORef++import Graphics.UI.Gtk hiding (focus)++import XMMS2.Client++import Utils+import Compound++import Collection.Common+import Collection.Tracks+import Collection.PropFlt+import Collection.Combo+import Collection.Utils+++data Select+ = S { sCombo :: ComboBox+ , sColl :: Coll+ , sBox :: VBox+ , sNextRef :: IORef VI+ }++instance ViewItem Select where+ nextVIRef = sNextRef++mkSelect env coll = do+ nextRef <- newIORef None+ box <- vBoxNew False 5+ combo <- mkCombo env+ let s = S { sCombo = combo+ , sBox = box+ , sColl = coll+ , sNextRef = nextRef+ }++ boxPackStart box combo PackNatural 0++ let setup w = do+ setNext s w+ onCollBuilt env w $ mkSelect env+ boxPackStartDefaults box $ outer w+ widgetGrabFocus $ focus w++ combo `on` changed $ do+ iter <- comboBoxGetActiveIter combo+ withJust iter $ \iter -> do+ cur <- listStoreGetValue (eCModel env) $ listStoreIterToIndex iter+ case cur of+ CITracks -> setup =<< mkTrackView env coll+ CIProp pr -> setup =<< mkPropFlt env pr coll+ CISeparator -> return ()++ widgetShowAll box+ return s++instance CompoundWidget Select where+ type Outer Select = VBox+ outer = sBox++instance FocusChild Select where+ type Focus Select = ComboBox+ focus = sCombo
+ src/Collection/Tracks.hs view
@@ -0,0 +1,206 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 5 Jul. 2011+--+-- Copyright (C) 2011 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.Tracks+ ( TrackView (..)+ , mkTrackView+ ) where++import Prelude hiding (lookup)++import Control.Applicative+import Control.Monad+import Control.Monad.Trans++import Data.Char+import Data.List hiding (lookup)+import Data.Maybe+import Data.IORef++import Graphics.UI.Gtk++import XMMS2.Client++import XMMS+import Utils+import Properties+import Config+import Index hiding (getInfo)+import qualified Index+import Medialib+import Compound++import Collection.Common+import Collection.Actions+import Collection.Utils+++data TrackView+ = TV { tStore :: ListStore MediaId+ , tIndex :: Index MediaInfo+ , tView :: TreeView+ , tSel :: TreeSelection+ , tScroll :: ScrolledWindow+ , tNextRef :: IORef VI+ }++instance CollBuilder TrackView where+ withBuiltColl tv f = do+ let store = tStore tv+ sel = tSel tv+ rows <- treeSelectionGetSelectedRows sel+ unless (null rows) $ do+ ids <- mapM (listStoreGetValue store . head) rows+ ils <- collNewIdlist ids+ f ils+ treeViewSel tv = (tView tv, tSel tv)++mkTrackView env coll = do+ store <- listStoreNewDND [] Nothing Nothing+ index <- makeIndex store return+ view <- treeViewNewWithModel store+ sel <- treeViewGetSelection view+ nextRef <- newIORef None+ scroll <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scroll ShadowIn+ scrolledWindowSetPolicy scroll PolicyNever PolicyAutomatic+ containerAdd scroll view+ let tv = TV { tStore = store+ , tIndex = index+ , tView = view+ , tSel = sel+ , tScroll = scroll+ , tNextRef = nextRef+ }+ setupView env tv+ loadTracks tv coll+ return tv++instance ViewItem TrackView where+ nextVIRef = tNextRef++setupView env tv = do+ let view = tView tv+ sel = tSel tv+ abRef = eABRef env+ ae = eAE env++ treeSelectionSetMode sel SelectionMultiple+ treeViewSetRulesHint view True+ setupTreeViewPopup view $ eVPopup env++ let aef = do+ foc <- view `get` widgetHasFocus+ when foc $ do+ rows <- treeSelectionGetSelectedRows sel+ aEnableSel ae $ not $ null rows+ aEnableRen ae False+ aEnableDel ae False+ setupViewFocus abRef view aef+ AB { aWithColl = withBuiltColl tv+ , aWithNames = const $ return ()+ , aSelection = Just sel+ }+ sel `on` treeSelectionSelectionChanged $ aef++ view `onDestroy` (killIndex $ tIndex tv)++ setColumns tv False =<< loadConfig+ widgetShowAll $ tScroll tv++loadTracks tv coll =+ collQueryIds xmms coll [] 0 0 >>* do+ ids <- result+ liftIO $ populateModel tv ids++setColumns tv save props = do+ let view = tView tv+ mapM_ (treeViewRemoveColumn view) =<< treeViewGetColumns view+ mapM_ (addColumn tv) props+ setupSearch tv props+ when save $ saveConfig props++addColumn tv prop = do+ let view = tView tv+ store = tStore tv+ column <- treeViewColumnNew+ treeViewAppendColumn view column+ treeViewColumnSetTitle column $ propName prop+ treeViewColumnSetResizable column True+ cell <- cellRendererTextNew+ treeViewColumnPackStart column cell True+ cellLayoutSetAttributeFunc column cell store $ \iter -> do+ maybeInfo <- getInfoIfNeeded tv iter+ let text = case maybeInfo of+ Just info -> fromMaybe "" $ lookup prop info+ Nothing -> ""+ cell `set` [ cellText := text ]++getInfoIfNeeded tv iter = do+ let n = listStoreIterToIndex iter+ mid <- listStoreGetValue (tStore tv) n+ rng <- treeViewGetVisibleRange $ tView tv+ getInfo tv mid $ case rng of+ ([f], [t]) | n >= f && t >= n -> Visible+ _ -> Background++loadConfig =+ catMaybes <$> (mapM property =<< config configFile defaultConfig)++saveConfig props = do+ writeConfig configFile $ map propName props+ return ()++configFile =+ "collection-view.conf"++defaultConfig =+ ["Artist", "Album", "Track", "Title"]++setupSearch tv props = do+ let store = tStore tv+ view = tView tv+ treeViewSetEnableSearch view True+ treeViewSetSearchEqualFunc view $ Just $ \str iter -> do+ mid <- listStoreGetValue store $ listStoreIterToIndex iter+ search (map toLower str) props <$> getInfo tv mid Search++search _ _ Nothing = False+search _ [] _ = False+search str (prop:props) (Just info) =+ let ptext = map toLower $ fromMaybe "" $ lookup prop info in+ str `isInfixOf` ptext || search str props (Just info)++getInfo tv = Index.getInfo (tIndex tv)++populateModel tv ids = do+ mapM_ addOne ids+ where addOne id = do+ n <- listStoreAppend store id+ addToIndex index id n+ store = tStore tv+ index = tIndex tv++instance CompoundWidget TrackView where+ type Outer TrackView = ScrolledWindow+ outer = tScroll++instance FocusChild TrackView where+ type Focus TrackView = TreeView+ focus = tView
− src/Collection/UI.hs
@@ -1,156 +0,0 @@--- -*-haskell-*---- Vision (for the Voice): an XMMS2 client.------ Author: Oleg Belozeorov--- Created: 14 Jul. 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.UI- ( setupUI- ) where--import Control.Applicative-import Control.Monad.Trans--import Data.Maybe--import System.IO.Unsafe--import Graphics.UI.Gtk hiding (add)--import UI-import XMMS-import Handler-import Utils-import Properties- ( showPropertyImport- , showPropertyManager- , makeOrderDialog- , showOrderDialog )-import Compound-import Collection.View-import Collection.List.View-import Collection.Control---setupUI builder browse = do- context <- initListView builder- let ?context = context-- setupActions builder browse- setupConnection builder-- collFilter `onEntryActivate` applyFilter- collFilter `onIconPress` \icon ->- case icon of- PrimaryIcon -> entrySetText collFilter ""- SecondaryIcon -> applyFilter-- popup <- getWidget castToMenu "ui/collection-popup"- setupTreeViewPopup collView popup-- onCollectionActivated loadSelected- onCollectionListMidClick $ browseSelected browse- onCollectionListCR $ browseSelected browse-- popup <- getWidget castToMenu "ui/list-popup"- setupTreeViewPopup listView popup-- return ()--setupActions builder browse = do- orderDialog <- unsafeInterleaveIO $ makeOrderDialog $ \v -> do- let outerw = outer v- windowSetTitle outerw "Configure ordering"- windowSetDefaultSize outerw 500 400-- bindActions builder- [ ("new-window" , newWindow browse )- , ("edit-filter" , editFilter )- , ("all-media" , allMedia )- , ("configure-columns" , showViewConfigDialog )- , ("configure-ordering" , showOrderDialog orderDialog getOrder setOrder)- , ("manage-properties" , showPropertyManager )- , ("browse-in-new-window" , browseSelected browse )- , ("save-collection" , saveCollection )- , ("rename-collection" , renameCollection )- , ("delete-collection" , removeCollection )- , ("add-to-playlist" , addToPlaylist False )- , ("replace-playlist" , addToPlaylist True )- , ("coll-add-to-playlist" , collAddToPlaylist False )- , ("coll-replace-playlist" , collAddToPlaylist True )- , ("list-add-to-playlist" , listAddToPlaylist False )- , ("list-replace-playlist" , listAddToPlaylist True )- , ("copy" , editCopy )- , ("select-all" , editSelectAll )- , ("invert-selection" , editInvertSelection )- , ("edit-properties" , showPropertyEditor )- , ("export-properties" , showPropertyExport )- , ("import-properties" , showPropertyImport )- ]-- acts <- actions builder- [ "rename-collection"- , "delete-collection"- ]- onCollectionSelectionChanged $ do- en <- isJust <$> getSelectedCollection- mapM_ (`actionSetSensitive` en) acts-- acts <- actions builder- [ "add-to-playlist"- , "replace-playlist"- ]- let updatePA = liftIO $ do- list <- widgetGetIsFocus listView- coll <- widgetGetIsFocus collView- mapM_ (`actionSetSensitive` (list || coll)) acts- return False- setupPA w = do- w `on` focusInEvent $ updatePA- w `on` focusOutEvent $ updatePA- setupPA listView- setupPA collView-- acts <- actions builder- [ "copy"- , "edit-properties"- , "export-properties"- ]- let updateEdit = do- en <- (/= 0) <$> treeSelectionCountSelectedRows collSel- mapM_ (`actionSetSensitive` en) acts- collSel `onSelectionChanged` updateEdit-- flip timeoutAdd 0 $ do- updatePA- updateEdit- updateWindowTitle- return False-- return ()--setupConnection builder = do- ag <- builderGetObject builder castToActionGroup "server-actions"-- onServerConnectionAdd . ever $ \conn -> do- actionGroupSetSensitive ag conn- collFilter `set` [ secondaryIconSensitive := conn ]-- return ()---newWindow browse =- browse Nothing
+ src/Collection/Utils.hs view
@@ -0,0 +1,192 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 6 Jul. 2011+--+-- Copyright (C) 2011 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 GADTs, UndecidableInstances #-}++module Collection.Utils+ ( selectAll+ , invertSelection+ , setupViewFocus+ , addToPlaylist+ , saveCollection+ , renameCollection+ , deleteCollections+ , CollBuilder (..)+ , onCollBuilt+ , ViewItem (..)+ , VI (..)+ , Killable (..)+ , killThis+ , killNext+ , setNext+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans++import Data.IORef++import Graphics.UI.Gtk hiding (selectAll)++import XMMS2.Client++import XMMS+import Utils+import UI+import Compound++import Collection.Common+++selectAll =+ treeSelectionSelectAll++invertSelection sel = do+ rows <- treeSelectionGetSelectedRows sel+ treeSelectionSelectAll sel+ mapM_ (treeSelectionUnselectPath sel) rows++setupViewFocus abRef view aef ab = do+ view `on` focusInEvent $ liftIO $ do+ writeIORef abRef ab+ aef+ return False++addToPlaylist replace coll = do+ when replace $ playlistClear xmms Nothing >> return ()+ playlistAddCollection xmms Nothing coll []+ return ()++saveCollection coll = do+ res <- runDlg "Save collection" False (const True) ""+ withJust res $ \name -> do+ collSave xmms coll name "Collections"+ return ()++renameCollection [old] = do+ res <- runDlg "Rename collection" False (/= old) old+ withJust res $ \new -> do+ collRename xmms old new "Collections"+ return ()+renameCollection _ = return ()++deleteCollections =+ mapM_ (\name -> collRemove xmms name "Collections")++runDlg title enable isOk init = do+ dialog <- dialogNew+ windowSetTitle dialog title+ windowSetTransientFor dialog window+ windowSetModal dialog True+ windowGroupAddWindow windowGroup dialog++ dialogSetHasSeparator dialog False+ dialogAddButton dialog "gtk-cancel" ResponseCancel+ dialogAddButtonCR dialog "gtk-ok" ResponseOk+ dialogSetDefaultResponse dialog ResponseOk+ dialogSetResponseSensitive dialog ResponseOk enable++ box <- vBoxNew False 0+ containerSetBorderWidth box 7+ upper <- dialogGetUpper dialog+ containerAdd upper box++ entry <- entryNew+ entrySetText entry init+ editableSelectRegion entry 0 (-1)+ editableSetPosition entry (-1)+ boxPackStart box entry PackNatural 0++ let ok = do+ new <- trim <$> entryGetText entry+ return $ not (null new) && isOk new+ check = dialogSetResponseSensitive dialog ResponseOk =<< ok+ checkInsert str pos = check >> return (length str + pos)+ checkDelete _ _ = check+ entry `onEntryActivate` do+ ok <- ok+ when ok $ dialogResponse dialog ResponseOk+ entry `afterInsertText` checkInsert+ entry `afterDeleteText` checkDelete++ widgetShowAll dialog+ resp <- dialogRun dialog+ new <- trim <$> entryGetText entry+ widgetDestroy dialog++ return $ case resp of+ ResponseOk -> Just new+ _ -> Nothing+++class CollBuilder b where+ withBuiltColl :: b -> (Coll -> IO ()) -> IO ()+ treeViewSel :: b -> (TreeView, TreeSelection)++onCollBuilt env b f = do+ let (view, sel) = treeViewSel b+ doit = withBuiltColl b $ \c -> do+ n <- f c+ setNext b n+ addView env n+ view `on` keyPressEvent $ tryEvent $ do+ "Return" <- eventKeyName+ [] <- eventModifier+ liftIO doit+ view `on` buttonPressEvent $ tryEvent $ do+ LeftButton <- eventButton+ DoubleClick <- eventClick+ (x, y) <- eventCoordinates+ liftIO $ do+ Just (p, _, _) <- treeViewGetPathAtPos view (round x, round y)+ treeSelectionSelectPath sel p+ doit++class ViewItem i where+ nextVIRef :: i -> IORef VI++data VI where+ VI :: (ViewItem i, Killable i) => i -> VI+ None :: VI++class Killable k where+ kill :: k -> IO ()++instance (CompoundWidget w, WidgetClass (Outer w)) => Killable w where+ kill = widgetDestroy . outer++killThis :: (ViewItem i, Killable i) => i -> IO ()+killThis vi = do+ killNext vi+ kill vi++killNext :: ViewItem i => i -> IO ()+killNext vi = do+ next <- readIORef $ nextVIRef vi+ case next of+ VI ni -> do+ killThis ni+ writeIORef (nextVIRef vi) None+ _ -> return ()++setNext :: (ViewItem t, ViewItem n, Killable n) => t -> n -> IO ()+setNext t n = do+ killNext t+ writeIORef (nextVIRef t) $ VI n
− src/Collection/View.hs
@@ -1,164 +0,0 @@--- -*-haskell-*---- Vision (for the Voice): an XMMS2 client.------ Author: Oleg Belozeorov--- Created: 14 Jul. 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.View- ( initView- , collView- , collSel- , collFilter- , showViewConfigDialog- ) where--import Control.Monad-import Control.Applicative--import Data.IORef-import Data.Maybe-import Data.List (isInfixOf)-import Data.Char--import System.IO.Unsafe--import Graphics.UI.Gtk--import UI-import Config-import Compound-import Editor-import Context-import Prelude hiding (lookup)-import Properties-import Collection.Model---data View- = View { vView :: TreeView- , vSel :: TreeSelection- , vFilter :: Entry- , vConfigDlg :: EditorDialog (PropertyView ())- , vColumns :: IORef [Property]- }--collView = vView context-collSel = vSel context-collFilter = vFilter context-configDlg = vConfigDlg context-columns = vColumns context---initView builder = do- context <- initContext builder- let ?context = context-- treeViewSetModel collView collStore- treeViewSetRulesHint collView True- treeSelectionSetMode collSel SelectionMultiple-- setColumns False =<< loadConfig-- return ?context--showViewConfigDialog =- runEditorDialog configDlg- (map (, ()) <$> getColumns)- (setColumns True . map fst)- False window--initContext builder = do- view <- builderGetObject builder castToTreeView "collection-view"- sel <- treeViewGetSelection view- filter <- builderGetObject builder castToEntry "filter-entry"- configDlg <- unsafeInterleaveIO makeConfigDlg- columns <- newIORef []- return $ augmentContext- View { vView = view- , vSel = sel- , vFilter = filter- , vConfigDlg = configDlg- , vColumns = columns- }--getColumns =- readIORef columns--setColumns save props = do- mapM_ (treeViewRemoveColumn collView) =<< treeViewGetColumns collView- writeIORef columns props- mapM_ addColumn props- setupSearch props- when save $ saveConfig props--addColumn prop = do- column <- treeViewColumnNew- treeViewAppendColumn collView column- treeViewColumnSetTitle column $ propName prop- treeViewColumnSetResizable column True- cell <- cellRendererTextNew- treeViewColumnPackStart column cell True- cellLayoutSetAttributeFunc column cell collStore $ \iter -> do- maybeInfo <- getInfoIfNeeded iter- let text = case maybeInfo of- Just info -> fromMaybe "" $ lookup prop info- Nothing -> ""- cell `set` [ cellText := text ]--getInfoIfNeeded iter = do- [n] <- treeModelGetPath collStore iter- mid <- listStoreGetValue collStore n- rng <- treeViewGetVisibleRange collView- getInfo mid $ case rng of- ([f], [t]) -> n >= f && t >= n- _ -> False--makeConfigDlg =- makeEditorDialog [(stockApply, ResponseApply)]- (makePropertyView (, ())) $ \v -> do- let outerw = outer v- windowSetTitle outerw "Configure collection browser"- windowSetDefaultSize outerw 500 400--loadConfig =- catMaybes <$> (mapM property =<< config configFile defaultConfig)--saveConfig props = do- writeConfig configFile $ map propName props- return ()--configFile =- "collection-view.conf"--defaultConfig =- ["Artist", "Album", "Track", "Title"]--setupSearch props = do- treeViewSetEnableSearch collView True- treeViewSetSearchEqualFunc collView $ Just $ \str iter -> do- [n] <- treeModelGetPath collStore iter- mid <- listStoreGetValue collStore n- search (map toLower str) props <$> getInfo mid True--search _ _ Nothing = False-search _ [] _ = False-search str (prop:props) (Just info) =- let ptext = map toLower $ fromMaybe "" $ lookup prop info in- str `isInfixOf` ptext || search str props (Just info)--
src/Context.hs view
@@ -19,8 +19,13 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,+ FlexibleContexts, OverlappingInstances,- TypeOperators #-}+ TypeOperators,+ DeriveDataTypeable,+ UndecidableInstances,+ ImplicitParams,+ StandaloneDeriving #-} module Context ( ContextClass
+ src/Control/Concurrent/Makefile.in view
@@ -0,0 +1,1 @@+include @abs_top_srcdir@/Makefile
+ src/Control/Concurrent/STM/Makefile.in view
@@ -0,0 +1,1 @@+include @abs_top_srcdir@/Makefile
+ src/Control/Concurrent/STM/TGVar.hs view
@@ -0,0 +1,64 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 30 Jun. 2011+--+-- 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 MultiParamTypeClasses #-}++module Control.Concurrent.STM.TGVar+ ( TGVar+ , newTGVar+ , readTGVar+ , readTGVarIO+ , writeTGVar+ , TGWatch+ , newTGWatch+ , module Control.Concurrent.STM.Watch+ ) where++import Control.Concurrent.STM+import Control.Concurrent.STM.Watch++import Control.Applicative+++data TGVar a = T (TVar (a, Integer))++newTGVar x = T <$> newTVar (x, 1)++readTGVar (T v) = fst <$> readTVar v++readTGVarIO (T v) = fst <$> readTVarIO v++writeTGVar (T v) x = do+ (_, g) <- readTVar v+ writeTVar v (x, g + 1)+++data TGWatch a = W (TGVar a) (TVar Integer)++newTGWatch v = W v <$> newTVar 0++instance Watch a (TGWatch a) where+ watch (W (T v) g) = do+ this <- readTVar g+ (x, that) <- readTVar v+ if this /= that+ then do+ writeTVar g that+ return x+ else retry
+ src/Control/Concurrent/STM/TWatch.hs view
@@ -0,0 +1,55 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 3 Jun. 2011+--+-- 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 MultiParamTypeClasses #-}++module Control.Concurrent.STM.TWatch+ ( TWatch+ , newTWatch+ , newEmptyTWatch+ , module Control.Concurrent.STM.Watch+ ) where++import Control.Concurrent.STM+import Control.Concurrent.STM.Watch++import Control.Monad+++data Eq a => TWatch a =+ TWatch (TVar a) (TVar (Maybe a))++newTWatch :: Eq a => TVar a -> a -> STM (TWatch a)+newTWatch src = newTWatch' src . Just++newEmptyTWatch :: Eq a => TVar a -> STM (TWatch a)+newEmptyTWatch src = newTWatch' src Nothing++newTWatch' :: Eq a => TVar a -> Maybe a -> STM (TWatch a)+newTWatch' src = liftM (TWatch src) . newTVar++instance Eq a => Watch a (TWatch a) where+ watch (TWatch src cur) = do+ srcv <- readTVar src+ curv <- readTVar cur+ case curv of+ Just v | v == srcv -> retry+ _ -> do+ writeTVar cur $ Just srcv+ return srcv
+ src/Control/Concurrent/STM/Watch.hs view
@@ -0,0 +1,31 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 30 Jun. 2011+--+-- 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 MultiParamTypeClasses, FunctionalDependencies #-}++module Control.Concurrent.STM.Watch+ ( Watch (..)+ ) where++import Control.Concurrent.STM+++class Watch a w | w -> a where+ watch :: w -> STM a+
+ src/Control/Makefile.in view
@@ -0,0 +1,1 @@+include @abs_top_srcdir@/Makefile
+ src/Control/Monad/EnvIO.hs view
@@ -0,0 +1,100 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 13 Jul. 2010+--+-- Copyright (C) 2011 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 MultiParamTypeClasses,+ FunctionalDependencies,+ FlexibleInstances,+ UndecidableInstances #-}++module Control.Monad.EnvIO+ ( EnvM (..)+ , envsx+ , EnvIO (..)+ , env+ , runIn+ , runIn'+ ) where++import Prelude hiding (catch)++import Control.Applicative++import Control.Monad.Trans+import Control.Monad.W+import Control.Monad.ToIO+import Control.Monad.CatchIO++import Data.Env+++class (Monad m, MonadIO m) => EnvM ix a m | ix -> m a where+ envx :: ix -> m a+++newtype EnvIO e a = EnvIO { runEnvIO :: e -> IO a }++instance Functor (EnvIO e) where+ f `fmap` m = EnvIO $ \e -> do+ a <- runEnvIO m e+ return $ f a++instance Monad (EnvIO e) where+ return a = EnvIO $ const $ return a+ m >>= n = EnvIO $ \e -> do+ a <- runEnvIO m e+ runEnvIO (n a) e++instance MonadIO (EnvIO e) where+ liftIO = EnvIO . const++instance ToIO (EnvIO e) where+ toIO = do+ e <- env+ return $ W $ flip runEnvIO e++instance MonadCatchIO (EnvIO e) where+ m `catch` f = EnvIO $ \e ->+ (runEnvIO m e)+ `catch`+ (\x -> runEnvIO (f x) e)+ block = mapEnvIO block+ unblock = mapEnvIO unblock++instance EnvX ix a e => EnvM ix a (EnvIO e) where+ envx ix = extract ix <$> env+++env :: EnvIO e e+env = EnvIO $ return++mapEnvIO :: (IO a -> IO b) -> EnvIO e a -> EnvIO e b+mapEnvIO f m = EnvIO $ f . runEnvIO m++runIn :: EnvB ix a e e' b => b -> EnvIO e (W (EnvIO e') IO)+runIn t =+ runIn' $ flip build t++runIn' :: (e -> e') -> EnvIO e (W (EnvIO e') IO)+runIn' f = do+ e <- env+ return $ W $ \m ->+ runEnvIO m $ f e++envsx :: EnvX ix a e => ix -> (a -> b) -> EnvIO e b+envsx ix acc = acc <$> envx ix
+ src/Control/Monad/Makefile.in view
@@ -0,0 +1,1 @@+include @abs_top_srcdir@/Makefile
+ src/Control/Monad/ToIO.hs view
@@ -0,0 +1,40 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 27 Jun. 2011+--+-- Copyright (C) 2011 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 RankNTypes #-}++module Control.Monad.ToIO+ ( ToIO (..)+ , io+ ) where++import Control.Monad.Trans+import Control.Monad.W+++class (Monad t, MonadIO t) => ToIO t where+ toIO :: t (W t IO)++io :: ToIO m => ((forall a. m a -> IO a) -> IO b) -> m b+io f = do+ W run <- toIO+ liftIO $ f run++instance ToIO IO where+ toIO = return $ W id
+ src/Control/Monad/W.hs view
@@ -0,0 +1,37 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 29 Jun. 2011+--+-- Copyright (C) 2011 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 RankNTypes #-}++module Control.Monad.W+ ( W (..)+ , ($>)+ ) where++import Control.Monad.Trans+++newtype W m n = W { runW :: forall a. m a -> n a }++($>) :: MonadIO m => m (W n IO) -> n b -> m b+w $> f = do+ W run <- w+ liftIO $ run f++infixr 0 $>
+ src/Data/Env.hs view
@@ -0,0 +1,74 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 13 Jul. 2010+--+-- Copyright (C) 2011 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 TypeOperators,+ MultiParamTypeClasses,+ FunctionalDependencies,+ FlexibleInstances,+ OverlappingInstances,+ UndecidableInstances #-}++module Data.Env+ ( Env (..)+ , mkEnv+ , (:*:) (..)+ , EnvX (..)+ , EnvB (..)+ , Extract (..)+ ) where+++newtype Env ix a = Env a++mkEnv :: ix -> a -> Env ix a+mkEnv = const Env++data a :*: b = a :*: b+infixr 9 :*:+++class EnvX ix a e | ix e -> a where+ extract :: ix -> e -> a++instance EnvX ix a ((Env ix a) :*: b) where+ extract _ ((Env a) :*: _) = a++instance EnvX ix a e => EnvX ix a (b :*: e) where+ extract ix (_ :*: e) = extract ix e+++class EnvB ix a e r k | k -> ix a r where+ build :: e -> k -> r++instance EnvB ix a e (Env ix a :*: ()) (Env ix a) where+ build _ k = k :*: ()++instance (EnvB ix a e (r :*: ()) k, EnvB ix2 a2 e r2 k2) => EnvB ix a e (r :*: r2) (k :*: k2) where+ build e (a :*: b) =+ let k :*: _ = build e a+ in k :*: (build e b)+++data Extract ix a = Extract++instance EnvX ix a e => EnvB ix a e (Env ix a :*: ()) (Extract ix a) where+ build e d = (Env $ extract (ix d) e) :*: ()+ where ix :: Extract ix a -> ix+ ix = const undefined+
+ src/Data/Makefile.in view
@@ -0,0 +1,1 @@+include @abs_top_srcdir@/Makefile
− src/Handler.hs
@@ -1,78 +0,0 @@--- -*-haskell-*---- Vision (for the Voice): an XMMS2 client.------ Author: Oleg Belozeorov--- Created: 11 Jun. 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 Handler- ( Id- , Handler- , make- , add- , remove- , invoke- , once- , ever- , keep- ) where--import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.Foldable---data Id m a = Id Int--type Entry m a = (Int, a -> m Bool)-type Entries m a = IntMap (Entry m a)--data Handler m a- = Handler { nextId :: Id m a- , entries :: Entries m a- }--make :: Handler m a-make = Handler { nextId = Id 0, entries = IntMap.empty }--add :: Monad m => (a -> m Bool) -> Handler m a -> m (Handler m a, Id m a)-add f Handler { nextId = id@(Id n), entries = e } =- return (h, id)- where h = Handler { nextId = Id $ succ n- , entries = IntMap.insert n (n, f) e- }--remove :: Monad m => Id m a -> Handler m a -> m (Handler m a, ())-remove (Id n) h =- return (h { entries = IntMap.delete n $ entries h }, ())--invoke :: Monad m => a -> Handler m a -> m (Handler m a, ())-invoke a h@Handler { entries = e } = do- e' <- foldlM (invoke' a) e e- return (h { entries = e' }, ())- where invoke' a e (i, f) = do- p <- f a- if p- then return e- else return $ IntMap.delete i e--once :: Monad m => (a -> m b) -> a -> m Bool-once = keep False--ever :: Monad m => (a -> m b) -> a -> m Bool-ever = keep True--keep :: Monad m => Bool -> (a -> m b) -> a -> m Bool-keep r f a = f a >> return r
src/Index.hs view
@@ -22,12 +22,17 @@ module Index ( Index , makeIndex+ , killIndex , getInfo , addToIndex , clearIndex ) where -import Control.Concurrent.MVar+import Control.Monad++import Control.Concurrent+import Control.Concurrent.STM+ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap @@ -35,19 +40,19 @@ import XMMS2.Client -import Medialib hiding (getInfo)-import Handler+import Medialib data IndexEntry i = IENone- | IERetrieving+ | IERetrieving RequestPriority | IEReady Stamp MediaInfo i data Index i = Index { iTable :: MVar (IntMap (IndexEntry i, [TreeRowReference])) , iStore :: ListStore MediaId , iConv :: MediaInfo -> IO i+ , iTid :: ThreadId } makeIndex store conv = do@@ -55,13 +60,18 @@ let index = Index { iTable = table , iStore = store , iConv = conv+ , iTid = undefined } - onMediaInfo . add . ever $ handleInfo index+ mic <- atomically $ dupTChan mediaInfoChan+ tid <- forkIO $ handleInfo index mic - return index+ return index { iTid = tid } -handleInfo index (id, stamp, info) = do+killIndex = killThread . iTid++handleInfo index chan = forever $ do+ (id, stamp, info) <- atomically $ readTChan chan let id' = fromIntegral id modifyMVar_ (iTable index) $ \ix -> case IntMap.lookup id' ix of@@ -74,7 +84,7 @@ if upd then do ti <- iConv index info- mapM_ (touch index) list+ idleAdd (mapM_ (touch index) list >> return False) priorityDefaultIdle return $ IntMap.insert id (IEReady stamp info ti, list) ix else return ix@@ -91,17 +101,21 @@ _ -> return () -getInfo index id force = do+getInfo index id prio = do let id' = fromIntegral id modifyMVar (iTable index) $ \ix -> case IntMap.lookup id' ix of Just (IEReady _ _ info, _) -> return (ix, Just info)- Just (IENone, list) | force -> do- requestInfo id- return (IntMap.insert id'(IERetrieving, list) ix, Nothing)+ Just (IENone, list) -> do+ requestInfo prio id+ return (IntMap.insert id' (IERetrieving prio, list) ix, Nothing)+ Just (IERetrieving old, list) | old > prio -> do+ requestInfo prio id+ return (IntMap.insert id' (IERetrieving prio, list) ix, Nothing) _ -> return (ix, Nothing)+ addToIndex index id n = modifyMVar_ (iTable index) $ \ix -> do
src/Location/Control.hs view
@@ -22,7 +22,6 @@ , makeURL , addToPlaylist , replacePlaylist- , updateWindowTitle , openLocation ) where @@ -43,6 +42,7 @@ import Location.History import Location.Model import Location.View+import Location.PathComp loadLocation location = do@@ -51,15 +51,18 @@ case maybeURL of Just url -> do addToHistory url- updateWindowTitle+ clearPathComp locationComp entrySetText locationEntry url xformMediaBrowse xmms url >>* handleBrowse url Nothing -> return () handleBrowse url =- handleBrowse' `catch` \(_ :: XMMSException) ->- liftIO $ putStrLn $ "error loading " ++ url+ handleBrowse' `catch` \(e :: XMMSException) -> do+ let t = case e of+ XMMSError s -> s+ _ -> "Unknown error"+ liftIO $ informUser MessageError $ escapeMarkup url ++ ": <b>" ++ escapeMarkup t ++ "</b>" where handleBrowse' = do r <- result liftIO $ do@@ -99,12 +102,6 @@ liftIO $ playlistAddURL xmms Nothing path return ())) return ()--updateWindowTitle = do- loc <- getCurrentLocation- setWindowTitle $ case loc of- [] -> "Vision location browser"- _ -> loc ++ " - Vision location browser" openLocation = do widgetGrabFocus locationEntry
src/Location/Model.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 28 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -26,7 +26,7 @@ , locationStore , sortModel , getCurrentLocation- , onLocation+ , location , LocationChange (..) , updateLocation , canGo@@ -37,6 +37,10 @@ ) where import Control.Concurrent.MVar++import Control.Concurrent.STM+import Control.Concurrent.STM.TGVar+ import Control.Applicative import Data.List@@ -48,7 +52,6 @@ import Context import Utils-import Handler data Location@@ -103,14 +106,10 @@ data State- = State { sLocation :: Location- , sOrder :: SortType- }+ = State { sOrder :: SortType } makeState order =- State { sLocation = makeLocation- , sOrder = order- }+ State { sOrder = order } data Item = Item { iName :: String@@ -137,36 +136,34 @@ data Model- = Model { mState :: MVar State- , mStore :: ListStore Item- , mSort :: TypedTreeModelSort Item- , mOnLocation :: HandlerMVar ()+ = Model { mState :: MVar State+ , mStore :: ListStore Item+ , mSort :: TypedTreeModelSort Item+ , mLocation :: TGVar Location } locationStore = mStore context sortModel = mSort context-onLocation = onHandler $ mOnLocation context+location = mLocation context state = mState context -getCurrentLocation =- withMVar state $ return . lCurrent . sLocation+getCurrentLocation = lCurrent <$> readTGVarIO location -updateLocation change = do- r <- modifyMVar state $ \s -> do- let (l, u) = changeLocation change $ sLocation s- return (s { sLocation = l }, u)- onLocation $ invoke ()- return r+updateLocation change = atomically $ do+ old <- readTGVar location+ let (new, u) = changeLocation change old+ writeTGVar location new+ return u -canGo = withMVar state $ \s ->- let Location { lCurrent = c- , lBack = b- , lForward = f- } = sLocation s- in return (not $ null b,- not $ null f,- not $ null c || isSuffixOf "//" c,- not $ null c)+canGo = atomically $ do+ Location { lCurrent = c+ , lBack = b+ , lForward = f+ } <- readTGVar location+ return (not $ null b,+ not $ null f,+ not $ null c || isSuffixOf "//" c,+ not $ null c) initModel order = do@@ -179,15 +176,15 @@ initContext order = do- state <- newMVar $ makeState order- store <- listStoreNewDND [] Nothing Nothing- sort <- treeModelSortNewWithModel store- onLocation <- makeHandlerMVar+ state <- newMVar $ makeState order+ store <- listStoreNewDND [] Nothing Nothing+ sort <- treeModelSortNewWithModel store+ location <- atomically $ newTGVar makeLocation return $ augmentContext- Model { mState = state- , mStore = store- , mSort = sort- , mOnLocation = onLocation+ Model { mState = state+ , mStore = store+ , mSort = sort+ , mLocation = location } split [] = []@@ -218,4 +215,4 @@ setSortOrder order = do modifyMVar_ state $ \s -> return s { sOrder = order }- treeSortableSetDefaultSortFunc sortModel $ compareIters order+ treeSortableSetDefaultSortFunc sortModel $ Just $ compareIters order
+ src/Location/PathComp.hs view
@@ -0,0 +1,90 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 21 Sep. 2010+--+-- Copyright (C) 2009-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.PathComp+ ( PathComp+ , makePathComp+ , pathComp+ , updatePathComp+ , clearPathComp+ ) where++import Control.Monad+import Control.Monad.Trans++import Prelude hiding (catch)+import Control.Monad.CatchIO++import Data.IORef++import System.FilePath++import Graphics.UI.Gtk++import XMMS2.Client++import XMMS+import Utils+++data PathComp+ = PathComp+ { pathComp :: EntryCompletion+ , pStore :: ListStore String+ , pURL :: IORef String+ }+++makePathComp = do+ comp <- entryCompletionNew+ store <- listStoreNewDND [] Nothing Nothing+ url <- newIORef ""++ entryCompletionSetModel comp $ Just store+ entryCompletionSetTextModel comp store++ entryCompletionSetPopupCompletion comp True+ entryCompletionSetPopupSingleMatch comp False+ entryCompletionSetInlineCompletion comp True++ return PathComp { pathComp = comp+ , pStore = store+ , pURL = url+ }++updatePathComp pc url = do+ let (hd, _) = splitFileName url+ old <- readIORef $ pURL pc+ unless (old == hd) $ do+ writeIORef (pURL pc) hd+ xformMediaBrowse xmms hd >>* do+ (flip catch) (\(_ :: XMMSException) -> return ()) $ do+ r <- result+ liftIO $ do+ listStoreClear $ pStore pc+ forM_ r $ \e ->+ when (entryIsDir e) $ do+ listStoreAppend (pStore pc) . decodeURL $ entryPath e+ return ()+ entryCompletionInsertPrefix $ pathComp pc+ entryCompletionComplete $ pathComp pc++clearPathComp pc = do+ listStoreClear $ pStore pc+ writeIORef (pURL pc) ""+
src/Location/UI.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 28 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -25,11 +25,14 @@ import Control.Monad import Control.Monad.Trans +import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TGVar+ import Graphics.UI.Gtk hiding (add) import UI import XMMS-import Handler import Utils import Location.Model import Location.View@@ -86,13 +89,15 @@ actionSetSensitive up eu actionSetSensitive refresh er + lW <- atomically $ newTGWatch location+ forkIO $ forever $ do+ void $ atomically $ watch lW+ postGUISync $ do+ updateN+ updateWindowTitle+ locationSel `onSelectionChanged` updateB- onLocation . add . ever . const $ updateN- flip timeoutAdd 0 $ do- updateB- updateN- updateWindowTitle- return False+ postGUIAsync updateB return () @@ -149,8 +154,9 @@ setupConnection builder = do ag <- builderGetObject builder castToActionGroup "server-actions"-- onServerConnectionAdd . ever $ \conn -> do+ xcW <- atomically $ newTGWatch connectedV+ forkIO $ forever $ do+ conn <- atomically $ watch xcW actionGroupSetSensitive ag conn locationEntry `set` [secondaryIconSensitive := conn] @@ -185,3 +191,9 @@ newWindow browse = do order <- getSortOrder browse order Nothing++updateWindowTitle = do+ loc <- getCurrentLocation+ setWindowTitle $ case loc of+ [] -> "Vision location browser"+ _ -> loc ++ " - Vision location browser"
src/Location/View.hs view
@@ -22,27 +22,36 @@ , locationView , locationSel , locationEntry+ , locationComp ) where +import Control.Applicative+import Control.Monad+import Control.Monad.Trans+ import Data.List import Data.Char+import Data.Maybe import Graphics.UI.Gtk import Context+import Environment import Location.Model-import Location.History+import Location.PathComp data View = View { vView :: TreeView , vSel :: TreeSelection , vEntry :: Entry+ , vComp :: PathComp } locationView = vView context locationSel = vSel context locationEntry = vEntry context+locationComp = vComp context initView builder = do@@ -87,9 +96,25 @@ item <- itemByIter iter return $ isInfixOf (map toLower str) (map toLower $ iName item) - comp <- makeHistoryCompletion- entrySetCompletion locationEntry comp+ entrySetCompletion locationEntry $ pathComp locationComp + locationEntry `onEditableChanged` do+ url <- entryGetText locationEntry+ updatePathComp locationComp url++ locationEntry `on` keyPressEvent $ tryEvent $ do+ [] <- eventModifier+ "Tab" <- eventKeyName+ liftIO $ do+ (url, modify, ofs) <- makeURL <$> entryGetText locationEntry+ when modify $ do+ pos <- editableGetPosition locationEntry+ entrySetText locationEntry url+ editableSetPosition locationEntry $ pos + ofs+ updatePathComp locationComp url+ entryCompletionInsertPrefix $ pathComp locationComp+ entryCompletionComplete $ pathComp locationComp+ return ?context @@ -97,9 +122,20 @@ view <- builderGetObject builder castToTreeView "location-view" sel <- treeViewGetSelection view entry <- builderGetObject builder castToEntry "location-entry"+ comp <- makePathComp return $ augmentContext View { vView = view , vSel = sel , vEntry = entry+ , vComp = comp } +makeURL url+ | "://" `isInfixOf` url =+ (url, False, 0)+ | "~/" `isPrefixOf` url && isJust homeDir =+ let pfx = "file://" ++ fromJust homeDir+ len = length pfx + length url - 1+ in (pfx ++ tail url, True, len)+ | otherwise =+ ("file://" ++ url, True, 7)
src/Medialib.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 18 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -20,42 +20,49 @@ module Medialib ( Stamp , MediaInfo+ , RequestPriority (..) , initMedialib , requestInfo- , onMediaInfo- , getInfo , retrieveProperties+ , mediaInfoChan ) where -import Control.Concurrent.MVar-import Control.Monad+import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TGVar++import Control.Monad (when, void, forever) import Control.Monad.Trans import Data.Map (Map) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap-import Data.Maybe-import Data.List-import Data.IORef--import Graphics.UI.Gtk hiding (add, remove)+import qualified Data.IntSet as IntSet+import Data.PSQueue (PSQ, Binding (..))+import qualified Data.PSQueue as PSQ import XMMS2.Client import XMMS2.Client.Bindings (propdictToDict) -import Utils import Context import XMMS-import Handler+import Utils type Stamp = Int type MediaInfo = Map String Property +data RequestPriority+ = Current+ | Visible+ | Search+ | Changed+ | Background+ deriving (Eq, Ord) data CacheEntry = CEReady Stamp MediaInfo- | CERetrieving+ | CERetrieving RequestPriority data Cache = Cache { cEntries :: IntMap CacheEntry@@ -69,97 +76,139 @@ data MLib- = MLib { mCache :: MVar Cache- , mOnMediaInfo :: HandlerMVar (MediaId, Stamp, MediaInfo)+ = MLib { mCache :: TVar (Maybe Cache)+ , mMediaInfoChan :: TChan (MediaId, Stamp, MediaInfo)+ , mReqQ :: TVar (PSQ MediaId RequestPriority) } -cache = mCache context---onMediaInfo = onHandler $ mOnMediaInfo context+cache = mCache context+reqQ = mReqQ context+mediaInfoChan = mMediaInfoChan context initMedialib = do context <- initContext let ?context = context - onServerConnectionAdd . ever $ \conn ->- if conn- then broadcastMedialibEntryChanged xmms >>* do- id <- result- let id' = fromIntegral id- liftIO $ withMVar cache $ \cache ->- when (isJust . IntMap.lookup id' $ cEntries cache) $- medialibGetInfo xmms id >>* handleInfo id'- persist- else- modifyMVar_ cache $ \cache ->- return cache { cEntries = IntMap.empty }+ xcW <- atomically $ newTGWatch connectedV+ let mon xc+ | xc = do+ atomically $ writeTVar cache $ Just emptyCache+ broadcastMedialibEntryChanged xmms >>* do+ id <- result+ let id' = fromIntegral id+ liftIO $ atomically $ do+ cc <- readTVar cache+ withJust cc $ \cc ->+ when (IntMap.member id' $ cEntries cc) $ do+ r <- readTVar reqQ+ writeTVar reqQ $ PSQ.insert id Changed r+ persist+ rt <- forkIO infoReqJob+ xc <- atomically $ watch xcW+ killThread rt+ atomically $ do+ writeTVar cache Nothing+ writeTVar reqQ PSQ.empty+ mon xc+ | otherwise = do+ xc <- atomically $ watch xcW+ mon xc+ forkIO $ mon False return ?context -requestInfo id =- modifyMVar_ cache $ \cache ->+requestInfo prio id = atomically $ do+ cc <- readTVar cache+ withJust cc $ \cc -> let id' = fromIntegral id- entries = cEntries cache in- case IntMap.lookup id' entries of+ entries = cEntries cc+ in case IntMap.lookup id' entries of Nothing -> do- medialibGetInfo xmms id >>* handleInfo id'- return cache { cEntries = IntMap.insert id' CERetrieving $ cEntries cache }+ r <- readTVar reqQ+ writeTVar reqQ $ PSQ.insert id prio r+ writeTVar cache $ Just+ cc { cEntries = IntMap.insert id' (CERetrieving prio) entries }+ Just (CERetrieving old) | old > prio -> do+ r <- readTVar reqQ+ writeTVar reqQ $ PSQ.update (const $ Just prio) id r+ writeTVar cache $ Just+ cc { cEntries = IntMap.insert id' (CERetrieving prio) entries } Just (CEReady s i) -> do- idleAdd (onMediaInfo (invoke (id, s, i)) >> return False) priorityHighIdle- return cache- _ ->- return cache-+ writeTChan mediaInfoChan (id, s, i)+ void $ readTChan mediaInfoChan+ _ -> return () initContext = do- cache <- newMVar emptyCache- onMediaInfo <- makeHandlerMVar+ cache <- newTVarIO Nothing+ mediaInfoChan <- newTChanIO+ reqQ <- newTVarIO PSQ.empty return $ augmentContext- MLib { mCache = cache- , mOnMediaInfo = onMediaInfo }--handleInfo id = do- rawv <- resultRawValue- liftIO $ do- info <- valueGet =<< propdictToDict rawv []- stamp <- modifyMVar cache $ \cache ->- let stamp = cNextStamp cache- entries = cEntries cache- entry = CEReady stamp info in- return (Cache { cEntries = IntMap.insert id entry entries- , cNextStamp = succ stamp }, stamp)- onMediaInfo $ invoke (fromIntegral id, stamp, info)--getInfo id =- withMVar cache $ \cache ->- return $ case IntMap.lookup (fromIntegral id) $ cEntries cache of- Just (CEReady _ info) -> Just info- _ -> Nothing+ MLib { mCache = cache+ , mMediaInfoChan = mediaInfoChan+ , mReqQ = reqQ+ } retrieveProperties ids f = do- let ids' = nub ids- len = length ids'+ let ids' = IntSet.fromList $ map fromIntegral ids+ len = IntSet.size ids' step = len `div` 100 - ref <- newIORef (0, ids', [])- hid <- onMediaInfo . add $ \(id, _, info) -> do- (ctr, todo, ready) <- readIORef ref- case todo of- (i:is) | i == id ->- if null is- then do- f . Right $ reverse ((id, info) : ready)- return False- else do- let ctr' = ctr + 1- when (step == 0 || ctr' `mod` step == 0) $- f . Left $ fromIntegral ctr' / fromIntegral len- requestInfo $ head is- writeIORef ref (ctr', is, (id, info) : ready)- return True- _ ->- return True+ chan <- atomically $ dupTChan mediaInfoChan+ let handler st@(ctr, todo, ready) = do+ (id, _, info) <- atomically $ readTChan chan+ let id' = fromIntegral id+ if IntSet.member id' todo+ then do+ let todo' = IntSet.delete id' todo+ if IntSet.null todo'+ then do+ f . Right $ reverse ((id, info) : ready)+ return ()+ else do+ let ctr' = ctr + 1+ when (step == 0 || ctr' `mod` step == 0) $+ f . Left $ fromIntegral ctr' / fromIntegral len+ handler (ctr', todo', (id, info) : ready)+ else+ handler st - requestInfo $ head ids- return . onMediaInfo $ remove hid+ tid <- forkIOUnmasked $ handler (0, ids', [])+ forkIO $ mapM_ (requestInfo Background . fromIntegral) $ IntSet.toList ids'++ return $ killThread tid++infoReqJob = do+ tv <- newTVarIO 0+ forever $ do+ id <- atomically $ do+ c <- readTVar tv+ when (c > 100) retry+ r <- readTVar reqQ+ case PSQ.minView r of+ Nothing -> retry+ Just (id :-> _, rest) -> do+ writeTVar reqQ rest+ writeTVar tv $ c + 1+ return id+ medialibGetInfo xmms id >>* do+ rawv <- resultRawValue+ liftIO $ do+ info <- valueGet =<< propdictToDict rawv []+ stamp <- atomically $ do+ c <- readTVar tv+ writeTVar tv $ c - 1+ cc <- readTVar cache+ case cc of+ Just cc -> do+ let stamp = cNextStamp cc+ entries = cEntries cc+ entry = CEReady stamp info+ writeTVar cache $ Just+ Cache { cEntries = IntMap.insert (fromIntegral id) entry entries+ , cNextStamp = succ stamp+ }+ return $ Just stamp+ Nothing -> return Nothing+ withJust stamp $ \stamp -> atomically $ do+ writeTChan mediaInfoChan (id, stamp, info)+ void $ readTChan mediaInfoChan
src/Playback.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 20 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -17,12 +17,13 @@ -- General Public License for more details. -- +{-# LANGUAGE UndecidableInstances #-}+ module Playback ( initPlayback- , onPlaybackStatus- , onPlaybackStatusAdd- , onCurrentTrack+ , currentTrack , getPlaybackStatus+ , playbackStatus , getCurrentTrack , startPlayback , pausePlayback@@ -31,55 +32,52 @@ , prevTrack , nextTrack , requestCurrentTrack+ , PlaybackCC ) where +import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TGVar+ import Control.Arrow-import Control.Concurrent.MVar+import Control.Monad import Control.Monad.Trans -import XMMS2.Client+import XMMS2.Client hiding (playbackStatus)+import qualified XMMS2.Client as XC import XMMS-import Handler import Context import Utils -data State- = State { sCurrentTrack :: Maybe (Int, String)- , sStatus :: Maybe PlaybackStatus- }+class ContextClass Playback c => PlaybackCC c+instance ContextClass Playback c => PlaybackCC c data Playback- = Playback { pState :: MVar State- , pOnPlaybackStatus :: HandlerMVar (Maybe PlaybackStatus)- , pOnCurrentTrack :: HandlerMVar (Maybe (Int, String))+ = Playback { pPlaybackStatus :: TVar (Maybe PlaybackStatus)+ , pCurrentTrack :: TVar (Maybe (Int, String)) } -state = pState context--onPlaybackStatus = onHandler (pOnPlaybackStatus context)-onPlaybackStatusAdd f = do- id <- onPlaybackStatus . add $ f- f =<< getPlaybackStatus- return id--onCurrentTrack = onHandler (pOnCurrentTrack context)+playbackStatus = pPlaybackStatus context+currentTrack = pCurrentTrack context getPlaybackStatus =- withMVar state $ return . sStatus+ atomically $ readTVar playbackStatus getCurrentTrack =- withMVar state $ return . sCurrentTrack+ atomically $ readTVar currentTrack initPlayback = do context <- initContext let ?context = context - onServerConnectionAdd . ever $ \conn ->- if conn- then do+ xcW <- atomically $ newTGWatch connectedV+ forkIO $ forever $ do+ conn <- atomically $ watch xcW+ resetState+ when conn $ do broadcastPlaybackStatus xmms >>* do liftIO requestStatus persist@@ -88,48 +86,34 @@ liftIO requestCurrentTrack persist requestCurrentTrack- else- resetState return ?context initContext = do- state <- newMVar makeState- onPlaybackStatus <- makeHandlerMVar- onCurrentTrack <- makeHandlerMVar+ playbackStatus <- atomically $ newTVar Nothing+ currentTrack <- atomically $ newTVar Nothing return $ augmentContext- Playback { pState = state- , pOnPlaybackStatus = onPlaybackStatus- , pOnCurrentTrack = onCurrentTrack+ Playback { pPlaybackStatus = playbackStatus+ , pCurrentTrack = currentTrack } -makeState =- State { sCurrentTrack = Nothing- , sStatus = Nothing- }--resetState = do- modifyMVar_ state $ const $ return makeState- invokeOnPlaybackStatus+resetState = atomically $ do+ writeTVar playbackStatus Nothing+ writeTVar currentTrack Nothing -setStatus s = do- modifyMVar_ state $ \state ->- return state { sStatus = s }- invokeOnPlaybackStatus+setStatus s = atomically $+ writeTVar playbackStatus s requestStatus =- playbackStatus xmms >>* do+ XC.playbackStatus xmms >>* do status <- result liftIO . setStatus $ Just status requestCurrentTrack = playlistCurrentPos xmms Nothing >>* do new <- catchResult Nothing (Just . first fromIntegral)- liftIO $ do- old <- modifyMVar state $ \state ->- return (state { sCurrentTrack = new }, sCurrentTrack state)- onCurrentTrack $ invoke old+ liftIO $ atomically $ writeTVar currentTrack new startPlayback False = do playbackStart xmms@@ -164,9 +148,6 @@ playlistSetNextRel xmms (-1) playbackTickle xmms return ()--invokeOnPlaybackStatus =- onPlaybackStatus . invoke =<< getPlaybackStatus restartPlayback = do playbackTickle xmms
src/Playlist.hs view
@@ -22,6 +22,7 @@ , showPlaylist ) where +import Control.Monad.Trans import Graphics.UI.Gtk import UI@@ -41,29 +42,29 @@ initFormat showPlaylist = do- builder <- makeBuilder "playlist"+ builder <- liftIO $ makeBuilder "playlist" - context <- initUI builder+ context <- liftIO $ initUI builder let ?context = context - context <- initModel+ context <- liftIO $ initModel let ?context = context - context <- initIndex+ context <- liftIO $ initIndex let ?context = context - context <- initView builder+ context <- liftIO $ initView builder let ?context = context - context <- initPlaylistConfig+ context <- liftIO $ initPlaylistConfig let ?context = context - context <- initUpdate+ context <- liftIO $ initUpdate let ?context = context - setupSearch- setupDnD+ liftIO $ setupSearch+ liftIO $ setupDnD setupUI builder - widgetShowAll window+ liftIO $ widgetShowAll window
src/Playlist/Edit.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 26 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -17,6 +17,8 @@ -- General Public License for more details. -- +{-# LANGUAGE NoMonoLocalBinds #-}+ module Playlist.Edit ( editDelete , editCopy@@ -41,28 +43,31 @@ editDelete cut = do- tracks <- getSelectedTracks- when cut $ copyIds tracks- removeTracks tracks- maybeTrack <- currentTrackThisPlaylist- withJust maybeTrack $ \t ->- when (t `elem` tracks) restartPlayback+ tracks <- liftIO $ getSelectedTracks+ when cut $ (copyIds =<< liftIO (playlistGetIds tracks))+ liftIO $ do+ removeTracks tracks+ maybeTrack <- currentTrackThisPlaylist+ withJust maybeTrack $ \t ->+ when (t `elem` tracks) restartPlayback -editCopy = copyIds =<< getSelectedTracks+editCopy =+ copyIds =<< liftIO (playlistGetIds =<< getSelectedTracks) editPaste append = do- targets <- getClipboardTargets- paste targets- where paste targets+ clipboard <- clipboard+ targets <- getClipboardTargets+ liftIO $ paste clipboard targets+ where paste clipboard targets | xmms2MlibIdTarget `elem` targets =- p xmms2MlibIdTarget (selectionDataGet selectionTypeInteger) insertIds+ p clipboard xmms2MlibIdTarget (selectionDataGet selectionTypeInteger) insertIds | uriListTarget `elem` targets =- p uriListTarget selectionDataGetURIs insertURIs+ p clipboard uriListTarget selectionDataGetURIs insertURIs | stringTarget `elem` targets =- p stringTarget selectionDataGetText $ insertURIs . lines+ p clipboard stringTarget selectionDataGetText $ insertURIs . lines | otherwise = return ()- p target get put =+ p clipboard target get put = clipboardRequestContents clipboard target $ do maybeContents <- get withJust maybeContents $ \contents -> liftIO $ do@@ -85,12 +90,3 @@ elem xmms2MlibIdTarget targets || elem uriListTarget targets || elem stringTarget targets--copyIds tracks = do- ids <- playlistGetIds tracks- clipboardSetWithData clipboard- [(xmms2MlibIdTarget, 0)]- (const $ selectionDataSet selectionTypeInteger ids)- (return ())- return ()-
src/Playlist/Format.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 22 Feb. 2010 ----- Copyright (C) 2009-2010 Oleg Belozeorov+-- Copyright (C) 2009-2011 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@@ -28,11 +28,15 @@ , trackInfoAttrs , trackInfoText , trackInfoDuration- , onFormatsChanged+ , formatsGeneration ) where import Prelude hiding (lookup) +import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TWatch+ import Control.Applicative import Control.Monad @@ -49,7 +53,6 @@ import Config import Utils import Context-import Handler import Playlist.Format.Format import Playlist.Format.Parser @@ -74,7 +77,7 @@ , fFormatDefsRef :: IORef [String] , fLookupDuration :: MediaInfo -> String , fLookupURL :: MediaInfo -> String- , fOnFormatsChanged :: HandlerMVar ()+ , fGeneration :: TVar Integer } getMakeInfo = readIORef (fMakeInfoRef context)@@ -90,7 +93,7 @@ lookupDuration = fLookupDuration context lookupURL = fLookupURL context -onFormatsChanged = onHandler $ fOnFormatsChanged context+formatsGeneration = fGeneration context initFormat = do@@ -98,9 +101,12 @@ let ?context = context loadFormatDefs- onProperties . add . ever . const $- updateFormats True + prW <- atomically $ newEmptyTWatch propertiesGeneration+ forkIO $ forever $ do+ void $ atomically $ watch prW+ postGUISync $ updateFormats True+ return ?context initContext = do@@ -108,13 +114,13 @@ makeInfoRef <- newIORef $ const $ return ([], "") duration <- fromJust <$> property "Duration" url <- fromJust <$> property "URL"- onFormatsChanged <- makeHandlerMVar+ generation <- newTVarIO 0 return $ augmentContext Format { fMakeInfoRef = makeInfoRef , fFormatDefsRef = formatDefsRef , fLookupDuration = maybe "" escapeMarkup . lookup duration , fLookupURL = maybe "" escapeMarkup . lookup url- , fOnFormatsChanged = onFormatsChanged+ , fGeneration = generation } @@ -149,7 +155,9 @@ updateFormats notify = do putMakeInfo =<< makeMakeInfo =<< getFormats- when notify $ onFormatsChanged $ invoke ()+ when notify $ atomically $ do+ g <- readTVar formatsGeneration+ writeTVar formatsGeneration $ g + 1 makeTrackInfo info = do makeInfo <- getMakeInfo
src/Playlist/Format/Config.hs view
@@ -18,6 +18,7 @@ -- {-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module Playlist.Format.Config ( FormatView
src/Playlist/Index.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 21 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -25,23 +25,27 @@ , addToIndex ) where +import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TWatch+ import Control.Applicative-import Control.Concurrent.MVar+import Control.Monad+ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Graphics.UI.Gtk hiding (add) -import Medialib hiding (getInfo)+import Medialib import Context-import Handler import Playlist.Model import Playlist.Format data IndexEntry = IENone- | IERetrieving+ | IERetrieving RequestPriority | IEReady Stamp MediaInfo TrackInfo data Index@@ -54,8 +58,11 @@ context <- initContext let ?context = context - onMediaInfo . add . ever $ handleInfo- onFormatsChanged . add . ever . const $ handleFormats+ (atomically $ dupTChan mediaInfoChan) >>= forkIO . handleInfo+ fW <- atomically $ newTWatch formatsGeneration 0+ forkIO $ forever $ do+ void $ atomically $ watch fW+ postGUISync handleFormats return ?context @@ -65,7 +72,8 @@ return $ augmentContext Index { iTable = table } -handleInfo (id, stamp, info) = do+handleInfo chan = forever $ do+ (id, stamp, info) <- atomically $ readTChan chan let id' = fromIntegral id modifyMVar_ index $ \ix -> case IntMap.lookup id' ix of@@ -86,7 +94,7 @@ if upd then do ti <- makeTrackInfo info- mapM_ touch list+ idleAdd (mapM_ touch list >> return False) priorityDefault return $ IntMap.insert id (IEReady stamp info ti, list) ix else return ix@@ -100,15 +108,18 @@ [n] -> touchPlaylist n _ -> return () -getInfo id force = do+getInfo id prio = do let id' = fromIntegral id modifyMVar index $ \ix -> case IntMap.lookup id' ix of Just (IEReady _ _ info, _) -> return (ix, Just info)- Just (IENone, list) | force -> do- requestInfo id- return (IntMap.insert id'(IERetrieving, list) ix, Nothing)+ Just (IENone, list) -> do+ requestInfo prio id+ return (IntMap.insert id' (IERetrieving prio, list) ix, Nothing)+ Just (IERetrieving old, list) | old > prio -> do+ requestInfo prio id+ return (IntMap.insert id' (IERetrieving prio, list) ix, Nothing) _ -> return (ix, Nothing)
src/Playlist/Model.hs view
@@ -21,45 +21,42 @@ ( initModel , clearModel , playlistStore+ , playlistName , getPlaylistName , setPlaylistName+ , playlistSize+ , modPlaylistSize , getPlaylistSize , touchPlaylist- , onPlaylistUpdated- , beforeDeletingTrack , playlistGetIds ) where -import Control.Concurrent.MVar+import Control.Concurrent.STM import Data.Int import Graphics.UI.Gtk import Context-import Utils -data State- = State { sName :: Maybe String }- data Model = Model { mStore :: ListStore Int32- , mOnPlaylistUpdated :: HandlerMVar ()- , mBeforeDeletingTrack :: HandlerMVar Int- , mState :: MVar State+ , mPlaylistName :: TVar (Maybe String)+ , mPlaylistSize :: TVar Int } playlistStore = mStore context-onPlaylistUpdated = onHandler (mOnPlaylistUpdated context)-beforeDeletingTrack = onHandler (mBeforeDeletingTrack context)-state = mState context+playlistName = mPlaylistName context+playlistSize = mPlaylistSize context -getPlaylistName = withMVar state (return . sName)-setPlaylistName name = modifyMVar_ state $ \s ->- return s { sName = name }+getPlaylistName = readTVarIO playlistName+setPlaylistName = atomically . writeTVar playlistName getPlaylistSize = listStoreGetSize playlistStore+modPlaylistSize op = do+ sz <- readTVar playlistSize+ writeTVar playlistSize $ op sz touchPlaylist n = do Just iter <- treeModelGetIter playlistStore [n]@@ -81,16 +78,10 @@ initContext = do store <- listStoreNewDND [] Nothing Nothing- onPlaylistUpdated <- makeHandlerMVar- beforeDeletingTrack <- makeHandlerMVar- state <- newMVar makeState+ playlistName <- newTVarIO Nothing+ playlistSize <- newTVarIO 0 return $ augmentContext Model { mStore = store- , mOnPlaylistUpdated = onPlaylistUpdated- , mBeforeDeletingTrack = beforeDeletingTrack- , mState = state+ , mPlaylistName = playlistName+ , mPlaylistSize = playlistSize }--makeState =- State { sName = Nothing }-
src/Playlist/Search.hs view
@@ -26,6 +26,7 @@ import Graphics.UI.Gtk +import Medialib import Playlist.Model import Playlist.Index import Playlist.View@@ -37,5 +38,5 @@ treeViewSetSearchEqualFunc playlistView $ Just $ \str iter -> do [n] <- treeModelGetPath playlistStore iter mid <- listStoreGetValue playlistStore n- info <- getInfo mid True+ info <- getInfo mid Search return $ isInfixOf (map toLower str) (trackInfoText info)
src/Playlist/UI.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 22 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -17,21 +17,35 @@ -- General Public License for more details. -- +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+ module Playlist.UI ( setupUI ) where +import Control.Monad+import Control.Monad.Trans+import Control.Monad.W+import Control.Monad.ToIO+import Control.Monad.EnvIO++import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TWatch+import Control.Concurrent.STM.TGVar++import Data.Env+ import System.IO.Unsafe import Network.URL import Graphics.UI.Gtk hiding (add, remove) -import XMMS2.Client hiding (Data)+import XMMS2.Client hiding (Data, playbackStatus) import UI import XMMS-import Handler import Playback import Playtime import Volume@@ -41,6 +55,7 @@ import Collection import Compound import Editor+import Registry import Properties hiding (showPropertyEditor, showPropertyExport) import Playlist.Model import Playlist.View@@ -50,53 +65,57 @@ setupUI builder = do- setupActions builder- setupPlaybar builder+ setupWindowTitle - playlistView `onRowActivated` \[n] _ ->- playTrack n+ Just ptEnv <- getEnv playtimeEnv+ Just volEnv <- getEnv volumeEnv+ runIn (ptEnv :*: volEnv) $> setupPlaybar builder - popup <- getWidget castToMenu "ui/playlist-popup"- setupTreeViewPopup playlistView popup+ Just env <- getEnv clipboardEnv+ runIn (env :*: registryEnv) $> setupActions builder - window `onDestroy` mainQuit+ liftIO $ do+ playlistView `onRowActivated` \[n] _ ->+ playTrack n - return ()+ popup <- getWidget castToMenu "ui/playlist-popup"+ setupTreeViewPopup playlistView popup + window `onDestroy` mainQuit + return ()+ setupActions builder = do- urlEntryDialog <- unsafeInterleaveIO $ makeURLEntryDialog+ urlEntryDialog <- liftIO $ unsafeInterleaveIO $ makeURLEntryDialog - orderDialog <- unsafeInterleaveIO $ makeOrderDialog $ \v -> do+ orderDialog <- liftIO $ 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-- ag <- builderGetObject builder castToActionGroup "server-actions"- onServerConnectionAdd . ever $ actionGroupSetSensitive ag+ nw <- atomically $ newEmptyTWatch playlistName+ tid <- forkIO $ forever $ do+ name <- atomically $ watch nw+ windowSetTitle outerw $+ "Sort playlist" ++ maybe "" (": " ++) name+ outerw `onDestroy` (killThread tid) - bindActions builder+ W runR <- runIn registryEnv+ W runC <- runIn clipboardEnv+ liftIO $ bindActions builder [ ("play", startPlayback False) , ("pause", pausePlayback) , ("stop", stopPlayback) , ("prev", prevTrack) , ("next", nextTrack) , ("quit", mainQuit)- , ("cut", editDelete True)- , ("copy", editCopy)- , ("paste", editPaste False)- , ("append", editPaste True)- , ("delete", editDelete False)+ , ("cut", runC $ editDelete True)+ , ("copy", runC $ editCopy)+ , ("paste", runC $ editPaste False)+ , ("append", runC $ editPaste True)+ , ("delete", runC $ editDelete False) , ("select-all", editSelectAll) , ("invert-selection", editInvertSelection) , ("browse-location", browseLocation SortAscending Nothing)- , ("browse-collection", browseCollection Nothing)+ , ("browse-collection", runR $ browseCollection Nothing) , ("add-media", runURLEntryDialog urlEntryDialog) , ("clear-playlist", clearPlaylist) , ("sort-by", showOrderDialog orderDialog getOrder setOrder)@@ -107,97 +126,111 @@ , ("manage-properties", showPropertyManager) ] - play <- action builder "play"- pause <- action builder "pause"- stop <- action builder "stop"- prev <- action builder "prev"- next <- action builder "next"- cut <- action builder "cut"- copy <- action builder "copy"- paste <- action builder "paste"- append <- action builder "append"- delete <- action builder "delete"- editp <- action builder "edit-properties"- export <- action builder "export-properties"+ setupServerActionGroup builder+ setupPlaybackActions builder+ setupTrackActions builder+ setupSelectionActions builder+ setupClipboardActions builder - let setupPPS = do- ps <- getPlaybackStatus- let (ePlay, ePause, eStop) = case ps of- Just StatusPlay -> (False, True, True)- Just StatusPause -> (True, False, True)- _ -> (True, False, False)- actionSetSensitive play ePlay- actionSetVisible play ePlay- actionSetSensitive pause ePause- actionSetVisible pause ePause- actionSetSensitive stop eStop- setupPN = do- size <- getPlaylistSize- name <- getPlaylistName- cpos <- getCurrentTrack- let (ep, en) = case (name, cpos) of- (Just n, Just (ct, cn)) ->- (n == cn && ct > 0, n == cn && ct < size - 1)- _ ->- (False, False)- actionSetSensitive prev ep- actionSetSensitive next en- setupSel = do- n <- treeSelectionCountSelectedRows playlistSel- mapM_ (`actionSetSensitive` (n /= 0))- [cut, copy, delete, editp, export]- setupPA = do- en <- editCheckClipboard- mapM_ (`actionSetSensitive` en) [paste, append]+ return () - onPlaybackStatus . add . ever . const $ setupPPS- onCurrentTrack . add . ever . const $ setupPN- onPlaylistUpdated . add . ever . const $ (setupPN >> updateWindowTitle)- onClipboardTargets . add . ever . const $ setupPA- playlistSel `onSelectionChanged` setupSel- flip timeoutAdd 0 $ do- setupPPS- setupPN- setupPA- setupSel- updateWindowTitle- return False+setupServerActionGroup builder = liftIO $ do+ ag <- builderGetObject builder castToActionGroup "server-actions"+ cW <- atomically $ newTGWatch connectedV+ forkIO $ forever $ do+ c <- atomically $ watch cW+ actionGroupSetSensitive ag c - return ()+setupPlaybackActions builder = liftIO $ do+ play <- action builder "play"+ pause <- action builder "pause"+ stop <- action builder "stop"+ psW <- atomically $ newEmptyTWatch playbackStatus+ forkIO $ forever $ do+ ps <- atomically $ watch psW+ postGUISync $ do+ let (ePlay, ePause, eStop) = case ps of+ Just StatusPlay -> (False, True, True)+ Just StatusPause -> (True, False, True)+ _ -> (True, False, False)+ actionSetSensitive play ePlay+ actionSetVisible play ePlay+ actionSetSensitive pause ePause+ actionSetVisible pause ePause+ actionSetSensitive stop eStop -setupPlaybar builder = do- playbar <- builderGetObject builder castToToolbar "playbar"+setupTrackActions builder = liftIO $ do+ prev <- action builder "prev"+ next <- action builder "next"+ ctW <- atomically $ newEmptyTWatch currentTrack+ psW <- atomically $ newEmptyTWatch playlistSize+ forkIO $ forever $ do+ atomically $ (void $ watch ctW) `mplus` (void $ watch psW)+ size <- getPlaylistSize+ name <- getPlaylistName+ cpos <- getCurrentTrack+ let (ep, en) = case (name, cpos) of+ (Just n, Just (ct, cn)) ->+ (n == cn && ct > 0, n == cn && ct < size - 1)+ _ ->+ (False, False)+ actionSetSensitive prev ep+ actionSetSensitive next en - sep <- separatorToolItemNew- separatorToolItemSetDraw sep False- toolbarInsert playbar sep (-1)+setupSelectionActions builder = liftIO $ do+ acts <- mapM (action builder) ["cut", "copy", "delete", "edit-properties", "export-properties"]+ playlistSel `onSelectionChanged` setup acts+ postGUIAsync $ setup acts+ where setup acts = do+ n <- treeSelectionCountSelectedRows playlistSel+ mapM_ (`actionSetSensitive` (n /= 0)) acts +setupClipboardActions builder =+ runIn clipboardEnv $> do+ ts <- clipboardTargets+ io $ \run -> do+ acts <- mapM (action builder) ["paste", "append"]+ ctW <- atomically $ newEmptyTWatch ts+ forkIO $ forever $ do+ void $ atomically $ watch ctW+ en <- run editCheckClipboard+ mapM_ (`actionSetSensitive` en) acts++setupWindowTitle = liftIO $ do+ pnW <- atomically $ newEmptyTWatch playlistName+ forkIO $ forever $ do+ name <- atomically $ watch pnW+ setWindowTitle $ maybe "Vision playlist" (++ " - Vision playlist") name++setupPlaybar builder = do seekView <- makeSeekControl- seekItem <- toolItemNew- toolItemSetHomogeneous seekItem False- toolItemSetExpand seekItem True- containerAdd seekItem seekView- toolbarInsert playbar seekItem (-1)+ volView <- makeVolumeControl - sep <- separatorToolItemNew- separatorToolItemSetDraw sep False- toolbarInsert playbar sep (-1)+ liftIO $ do+ playbar <- builderGetObject builder castToToolbar "playbar" - volView <- makeVolumeControl- volumeItem <- toolItemNew- toolItemSetHomogeneous volumeItem False- toolItemSetExpand volumeItem False- widgetSetSizeRequest volumeItem 100 (-1)- containerAdd volumeItem volView- toolbarInsert playbar volumeItem (-1)+ sep <- separatorToolItemNew+ separatorToolItemSetDraw sep False+ toolbarInsert playbar sep (-1) - return ()+ seekItem <- toolItemNew+ toolItemSetHomogeneous seekItem False+ toolItemSetExpand seekItem True+ containerAdd seekItem seekView+ toolbarInsert playbar seekItem (-1) -updateWindowTitle = do- maybeName <- getPlaylistName- setWindowTitle $ case maybeName of- Nothing -> "Vision playlist"- Just name -> name ++ " - Vision playlist"+ sep <- separatorToolItemNew+ separatorToolItemSetDraw sep False+ toolbarInsert playbar sep (-1)++ volumeItem <- toolItemNew+ toolItemSetHomogeneous volumeItem False+ toolItemSetExpand volumeItem False+ widgetSetSizeRequest volumeItem 100 (-1)+ containerAdd volumeItem volView+ toolbarInsert playbar volumeItem (-1)++ return () data URLEntry =
src/Playlist/Update.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 20 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -19,7 +19,6 @@ module Playlist.Update ( initUpdate- , onPlaylistLoaded ) where import Control.Applicative@@ -27,92 +26,83 @@ import Control.Monad.Trans import Data.Maybe +import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TWatch+import Control.Concurrent.STM.TGVar+ import Graphics.UI.Gtk hiding (add) -import XMMS2.Client+import XMMS2.Client hiding (playbackStatus) import XMMS-import Handler-import Utils-import Context import Playback+import Utils import Playlist.Model import Playlist.Index -data Context- = Context { cOnPlaylistLoaded :: HandlerMVar () }--onPlaylistLoaded = onHandler $ cOnPlaylistLoaded context-- initUpdate = do- context <- initContext- let ?context = context-- onServerConnectionAdd . ever $ \conn ->- if conn- then do+ xcW <- atomically $ newTGWatch connectedV+ forkIO $ forever $ do+ conn <- atomically $ watch xcW+ setPlaylistName Nothing+ postGUISync clearModel+ when conn $ do playlistCurrentActive xmms >>* do setupPlaylist liftIO $ broadcastPlaylistChanged xmms >>* handleChange broadcastPlaylistLoaded xmms >>* do setupPlaylist persist- else do- setPlaylistName Nothing- clearModel- onPlaylistLoaded $ invoke () - onPlaybackStatus . add . ever . const $ do- maybeCT <- getCurrentTrack- name <- fromMaybe "" <$> getPlaylistName- size <- getPlaylistSize- case maybeCT of- Just (ct, cname) | cname == name && ct < size ->- touchPlaylist ct- _ ->- return ()+ psW <- atomically $ newTWatch playbackStatus Nothing+ forkIO $ forever $ do+ void $ atomically $ watch psW+ postGUISync $ do+ maybeCT <- getCurrentTrack+ name <- fromMaybe "" <$> getPlaylistName+ size <- getPlaylistSize+ case maybeCT of+ Just (ct, cname) | cname == name && ct < size ->+ touchPlaylist ct+ _ ->+ return () - onCurrentTrack . add . ever $ \old -> do- name <- fromMaybe "" <$> getPlaylistName- size <- getPlaylistSize- case old of- Just (ot, oname) | oname == name && ot < size ->- touchPlaylist ot- _ ->- return ()- new <- getCurrentTrack- case new of- Just (nt, nname) | nname == name && nt < size ->- touchPlaylist nt- _ ->- return ()+ ctW <- atomically $ newEmptyTWatch currentTrack+ let monCT old = do+ new <- atomically $ watch ctW+ postGUISync $ do+ name <- fromMaybe "" <$> getPlaylistName+ size <- getPlaylistSize+ withJust old $ \(ot, oname) ->+ when (oname == name && ot < size) $+ touchPlaylist ot+ withJust new $ \(nt, nname) ->+ when (nname == name && nt < size) $+ touchPlaylist nt+ monCT new+ forkIO $ monCT Nothing return ?context -initContext = do- onPlaylistLoaded <- makeHandlerMVar- return $ augmentContext- Context { cOnPlaylistLoaded = onPlaylistLoaded }- setupPlaylist = do name <- result liftIO $ do setPlaylistName $ Just name requestPlaylist name- onPlaylistLoaded $ invoke () requestPlaylist name = playlistListEntries xmms (Just name) >>* handlePlaylist handlePlaylist = do ids <- result+ len <- resultLength liftIO $ do clearModel mapM_ addToPlaylist ids+ atomically $ modPlaylistSize $ const $ fromIntegral len requestCurrentTrack- onPlaylistUpdated $ invoke () addToPlaylist id = do n <- listStoreAppend playlistStore id@@ -125,26 +115,23 @@ when (name == playlist change) $ case change of PlaylistRemove { position = p } -> do- beforeDeletingTrack $ invoke p listStoreRemove playlistStore p- onPlaylistUpdated $ invoke ()+ atomically $ modPlaylistSize pred PlaylistAdd { mlibId = id } -> do n <- listStoreAppend playlistStore id addToIndex id n- onPlaylistUpdated $ invoke ()+ atomically $ modPlaylistSize succ PlaylistInsert { mlibId = id, position = n } -> do listStoreInsert playlistStore n id addToIndex id n- onPlaylistUpdated $ invoke ()+ atomically $ modPlaylistSize succ PlaylistMove { mlibId = id, position = o, newPosition = n } -> do- beforeDeletingTrack $ invoke o listStoreRemove playlistStore o listStoreInsert playlistStore n id addToIndex id n- onPlaylistUpdated $ invoke () PlaylistClear {} -> do clearModel- onPlaylistUpdated $ invoke ()+ atomically $ modPlaylistSize $ const 0 _ -> requestPlaylist name persist
src/Playlist/View.hs view
@@ -18,6 +18,7 @@ -- {-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module Playlist.View ( initView@@ -29,13 +30,14 @@ import Control.Applicative import Data.Maybe+import Data.IORef import Graphics.UI.Gtk hiding (add) import XMMS2.Client import Context-import Handler+import Medialib import Playback import Playlist.Model import Playlist.Index@@ -44,10 +46,13 @@ data View = View { vView :: TreeView- , vSel :: TreeSelection }+ , vSel :: TreeSelection+ , vCur :: IORef (TreePath, Maybe TreeViewColumn)+ } playlistView = vView context playlistSel = vSel context+playlistCur = vCur context initView builder = do@@ -97,14 +102,18 @@ info <- getInfoIfNeeded iter cell `set` [ cellText := trackInfoDuration info ] - beforeDeletingTrack . add . ever $ \t -> do- cursor <- treeViewGetCursor playlistView- case cursor of- ([p], c) | p == t -> do- s <- getPlaylistSize- let p' = if p + 1 < s then p + 1 else max (p - 1) 0- c' = maybe Nothing (Just . (, False)) c- treeViewSetCursor playlistView [p'] c'+ playlistView `on` cursorChanged $ do+ cur <- treeViewGetCursor playlistView+ writeIORef playlistCur cur++ playlistStore `on` rowDeleted $ \[d] -> do+ cur <- readIORef playlistCur+ case cur of+ ([n], c) | n >= d -> do+ s <- getPlaylistSize+ let n' = if n < s && n == d then n else max (n - 1) 0+ c' = maybe Nothing (Just . (, False)) c+ treeViewSetCursor playlistView [n'] c' _ -> return () return ?context@@ -115,16 +124,19 @@ mid <- listStoreGetValue playlistStore n rng <- treeViewGetVisibleRange playlistView getInfo mid $ case rng of- ([f], [t]) -> n >= f && t >= n- _ -> False+ ([f], [t]) | n >= f && t >= n -> Visible+ _ -> Background initContext builder = do view <- builderGetObject builder castToTreeView "playlist-view" sel <- treeViewGetSelection view+ cur <- newIORef ([], Nothing) return $ augmentContext View { vView = view- , vSel = sel }+ , vSel = sel+ , vCur = cur+ } getSelectedTracks =
src/Playtime.hs view
@@ -17,177 +17,239 @@ -- General Public License for more details. -- +{-# LANGUAGE DeriveDataTypeable, UndecidableInstances #-}+ module Playtime ( initPlaytime , makeSeekControl+ , PlaytimeM+ , playtimeEnv ) where -import Control.Concurrent.MVar+import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TWatch+import Control.Concurrent.STM.TGVar+ import Control.Applicative import Control.Monad import Control.Monad.Trans+import Control.Monad.State+import Control.Monad.EnvIO -import qualified Data.Map as Map-import Data.IORef-import Data.Word import Data.Maybe+import qualified Data.Map as Map+import Data.Typeable+import Data.Env -import Graphics.UI.Gtk hiding (add, remove)+import Graphics.UI.Gtk hiding (add, remove, get) -import XMMS2.Client+import XMMS2.Client hiding (playbackStatus) import XMMS-import Handler import Medialib-import Context+import Context hiding (makeContext) import Utils import Playback+import Registry -data State- = State { sCurrentId :: Maybe MediaId }- data Playtime- = Playtime { pState :: MVar State- , pAdj :: Adjustment- , pCId :: ConnectId Adjustment }+ = Playtime { pAdj :: Adjustment+ , pCurrentIdV :: TVar (Maybe MediaId)+ , pPlaytimeV :: TVar Int+ , pSeekCountV :: TVar (Maybe Int)+ }+ deriving (Typeable) -state = pState context-cId = pCId context-adj = pAdj context+adj = pAdj context+currentIdV = pCurrentIdV context+playtimeV = pPlaytimeV context+seekCountV = pSeekCountV context -getCurrentId = withMVar state $ return . sCurrentId-setCurrentId id = modifyMVar_ state $ \s -> return s { sCurrentId = id } -initPlaytime = do- updateRef <- initUpdate- let ?updateRef = updateRef+data Ix = Ix deriving (Typeable) - context <- initContext- let ?context = context+class (EnvM Ix Playtime m) => PlaytimeM m+instance (EnvM Ix Playtime m) => PlaytimeM m - onServerConnectionAdd . ever $ \conn ->- if conn- then do- playbackCurrentId xmms >>* handleCurrentId- broadcastPlaybackCurrentId xmms >>* (handleCurrentId >> persist)- playbackPlaytime xmms >>* handlePlaytime 0- signalPlaybackPlaytime xmms >>* (handlePlaytime 1000 >> persist)- else do- resetState- setValue 0- resetUpdate (+ 1)+playtimeEnv :: Extract Ix Playtime+playtimeEnv = Extract - onMediaInfo . add . ever $ handleInfo- onPlaybackStatusAdd . ever $ \status ->- when (fromMaybe StatusStop status == StatusStop) $- setValue 0+initPlaytime = do+ pt <- liftIO $ makeContext+ let ?context = augmentContext pt+ addEnv Ix pt - return ?context+ liftIO $ do+ cId <- setupSeek+ xcW <- atomically $ newTGWatch connectedV+ let mon xc+ | xc = do+ rt <- forkIO requestPlaytime+ ct <- forkIO $ evalPTM cId dispatch+ xc <- atomically $ watch xcW+ killThread rt+ killThread ct+ atomically $ writeTVar seekCountV Nothing+ mon xc+ | otherwise = do+ xc <- atomically $ watch xcW+ mon xc+ forkIO $ mon False + return () -initContext = do- state <- newMVar makeState- adj <- adjustmentNew 0 0 bigNum 5000 5000 0- cId <- adj `onValueChanged` do- pos <- adjustmentGetValue adj- seek pos - return $ augmentContext- Playtime { pState = state- , pAdj = adj- , pCId = cId }+makeContext = do+ adj <- adjustmentNew 0 0 0 5000 5000 0+ currentIdV <- newTVarIO Nothing+ playtimeV <- newTVarIO 0+ seekCountV <- newTVarIO Nothing+ return $ Playtime { pAdj = adj+ , pCurrentIdV = currentIdV+ , pPlaytimeV = playtimeV+ , pSeekCountV = seekCountV+ } -makeState =- State { sCurrentId = Nothing }+requestPlaytime = forever $ do+ checkSeekCount+ playbackPlaytime xmms >>* do+ pt <- catchResult 0 fromIntegral+ liftIO $ atomically $ writeTVar playtimeV pt+ threadDelay 1000000 -resetState =- modifyMVar_ state $ const $ return makeState+checkSeekCount = atomically $ do+ rc <- readTVar seekCountV+ if rc == Just 0+ then return ()+ else retry +modSeekCount op = atomically $ do+ rc <- readTVar seekCountV+ withJust rc $ \rc ->+ writeTVar seekCountV $ Just $ op rc+ handleCurrentId = do- cid <- result- liftIO $ do- setValue 0- setUpper bigNum- setCurrentId $- if cid == 0- then Nothing- else Just cid- requestInfo cid+ ci <- catchResult Nothing Just+ liftIO $ atomically $ writeTVar currentIdV ci -handleInfo (id, _, info) = do- cid <- getCurrentId- when (cid == Just id) $- case Map.lookup "duration" info of- Just (PropInt32 d) -> setUpper $ fromIntegral d- _ -> return ()+setupSeek = adj `onValueChanged` do+ modSeekCount (+ 1)+ v <- adjustmentGetValue adj+ playbackSeekMs xmms (round v) SeekSet >>* do+ liftIO $ modSeekCount $ \n -> n - 1 -bigNum = 10000000000.0+makeSeekControl = do+ adj <- envsx Ix pAdj+ liftIO $ do+ view <- hScaleNew adj+ scaleSetDrawValue view False+ rangeSetUpdatePolicy view UpdateContinuous+ widgetSetCanFocus view False -seek pos = do- eid <- disableUpdate- playbackSeekMs xmms (round pos) SeekSet >>*- liftIO (scheduleEnableUpdate eid)- return ()+ w <- atomically $ newEmptyTWatch playbackStatus+ t <- forkIO $ forever $ do+ s <- atomically $ watch w+ widgetSetSensitive view $ s == (Just StatusPlay) -data Update- = Update { uEnabled :: Bool- , uEnablerId :: Maybe HandlerId- , uStamp :: Word32 }+ view `onDestroy` (killThread t) -initUpdate =- newIORef Update { uEnabled = True- , uEnablerId = Nothing- , uStamp = 0 }+ return view -resetUpdate f =- modifyIORef ?updateRef $ \up ->- up { uEnabled = True- , uEnablerId = Nothing- , uStamp = f $ uStamp up } -updateEnabled = uEnabled <$> readIORef ?updateRef+data S =+ S { sPt :: Int+ , sId :: Maybe MediaId+ , sTd :: Int+ , sPs :: PlaybackStatus+ , sCi :: ConnectId Adjustment+ } -disableUpdate = do- up <- readIORef ?updateRef- maybe (return ()) timeoutRemove $ uEnablerId up- let stamp = uStamp up + 1- writeIORef ?updateRef Update { uEnabled = False- , uEnablerId = Nothing- , uStamp = stamp }- return stamp+mkS id cId =+ S { sPt = 0+ , sId = id+ , sTd = 0+ , sPs = StatusStop+ , sCi = cId+ } -scheduleEnableUpdate stamp = do- eid <- flip timeoutAdd 500 $ do- stamp' <- uStamp <$> readIORef ?updateRef- when (stamp == stamp') $ resetUpdate id- return False- modifyIORef ?updateRef $ \up -> up { uEnablerId = Just eid }+evalPTM cId f =+ evalStateT f (mkS Nothing cId) -getValue = adjustmentGetValue adj-setValue = withoutSeek . adjustmentSetValue adj-setUpper = withoutSeek . adjustmentSetUpper adj+withoutSeek f = do+ cId <- gets sCi+ liftIO $ bracket_+ (signalBlock cId)+ (signalUnblock cId)+ (liftIO f) -withoutSeek =- bracket_ (signalBlock cId) (signalUnblock cId)+data Msg+ = PT Int+ | CI (Maybe MediaId)+ | MI (MediaId, Stamp, MediaInfo)+ | PS (Maybe PlaybackStatus) -handlePlaytime diff = do- newPt <- catchResult 0 fromIntegral- liftIO $ do- en <- updateEnabled- ps <- getPlaybackStatus- when (en && fromMaybe StatusStop ps /= StatusStop) $ do- oldPt <- getValue- when (abs (newPt - oldPt) >= diff) $ setValue newPt+dispatch = do+ (miC, ciW, psW, ptW) <- liftIO $ do+ playbackCurrentId xmms >>*+ handleCurrentId+ broadcastPlaybackCurrentId xmms >>*+ (handleCurrentId >> persist)+ atomically $ writeTVar seekCountV $ Just 0+ miC <- atomically $ dupTChan mediaInfoChan+ ciW <- atomically $ newTWatch currentIdV Nothing+ psW <- atomically $ newEmptyTWatch playbackStatus+ ptW <- atomically $ newEmptyTWatch playtimeV+ return (miC, ciW, psW, ptW)+ forever $ do+ msg <- liftIO $ atomically $+ msum [ PS <$> watch psW+ , CI <$> watch ciW+ , PT <$> watch ptW+ , MI <$> readTChan miC+ ]+ case msg of+ PT pt -> handlePT pt+ CI ci -> handleCI ci+ MI mi -> handleMI mi+ PS ps -> handlePS $ fromMaybe StatusStop ps -makeSeekControl = do- view <- hScaleNew adj- scaleSetDrawValue view False- rangeSetUpdatePolicy view UpdateContinuous- widgetSetCanFocus view False+handlePT pt = do+ s <- get+ unless (sPs s == StatusStop) $ do+ put s { sPt = pt }+ unless (sTd s == 0) $+ withoutSeek $ adjustmentSetValue adj $ fromIntegral pt - id <- onPlaybackStatusAdd . ever $- widgetSetSensitive view . (Just StatusPlay ==)- view `onDestroy` onPlaybackStatus (remove id)+handleCI id = do+ modify $ \s ->+ s { sPt = 0+ , sId = id+ , sTd = 0+ }+ withoutSeek $ do+ adjustmentSetValue adj 0+ adjustmentSetUpper adj 0+ liftIO $ withJust id $ requestInfo Current - return view+handleMI (id, _, info) = do+ s <- get+ when (sId s == Just id) $+ case Map.lookup "duration" info of+ Just (PropInt32 d) -> do+ put s { sTd = fromIntegral d }+ withoutSeek $ do+ adjustmentSetUpper adj $ fromIntegral d+ unless (sPs s == StatusStop) $+ adjustmentSetValue adj $ fromIntegral $ sPt s+ _ -> return ()++handlePS StatusStop = do+ modify $ \s ->+ s { sPs = StatusStop+ , sPt = 0+ }+ withoutSeek $ adjustmentSetValue adj 0+handlePS ps =+ modify $ \s -> s { sPs = ps }
src/Properties.hs view
@@ -27,7 +27,7 @@ , property , showPropertyManager , showPropertyEditor- , onProperties+ , propertiesGeneration , showPropertyExport , showPropertyImport , module Properties.View
src/Properties/Editor/Model.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 6 Jul. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -33,8 +33,13 @@ import Prelude hiding (lookup) -import Control.Concurrent.MVar-import Control.Monad.State hiding (State, withState)+import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TWatch+import Control.Concurrent.STM.TGVar++import Control.Monad+import Control.Monad.State hiding (State, withState, state) import Control.Applicative import Control.Arrow @@ -52,7 +57,6 @@ import Context import Config import Utils-import Handler import Medialib import Properties.Property import Properties.Model@@ -111,11 +115,16 @@ let ?context = context cid <- store `on` rowDeleted $ const saveConfig- onProperties . add . ever . const $- withSignalBlocked cid updateProperties - onServerConnection . add . ever $ \conn ->- unless conn $ do+ prW <- atomically $ newEmptyTWatch propertiesGeneration+ forkIO $ forever $ do+ void $ atomically $ watch prW+ postGUISync $ withSignalBlocked cid updateProperties++ xcW <- atomically $ newTGWatch connectedV+ forkIO $ forever $ do+ void $ atomically $ watch xcW+ postGUISync $ do resetModel touchAll
src/Properties/Editor/UI.hs view
@@ -17,12 +17,17 @@ -- General Public License for more details. -- +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+ module Properties.Editor.UI ( initEditorUI , showPropertyEditor ) where -import Control.Concurrent.MVar+import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TGVar+ import Control.Monad import Data.IORef@@ -31,7 +36,6 @@ import Context import Utils-import Handler import UI import XMMS import Medialib@@ -135,8 +139,10 @@ cancelRetrieval hideEditor - onServerConnection . add . ever $ \conn ->- unless conn $ do+ xcW <- atomically $ newTGWatch connectedV+ forkIO $ forever $ do+ void $ atomically $ watch xcW+ postGUISync $ do cancelRetrieval widgetSetSensitive prevB False widgetSetSensitive nextB False
src/Properties/Impex.hs view
@@ -91,7 +91,7 @@ let base = dropFileName $ decodeString file text = encodeStrict $ showJSON $ map (exConv base . snd) list writeFile file text `catch` \e ->- putStrLn $ "Export failed" +++ informUser MessageError $ "Property export failed: " ++ (decodeString file) ++ ": " ++ ioeGetErrorString e exConv base info = ((url', args), Map.difference info readOnlyProps)@@ -122,7 +122,7 @@ Error _ -> erep "invalid file format" base = dropFileName decn decn = decodeString name- erep = putStrLn . (("Import failed: " ++ decn ++ ": ") ++)+ erep = informUser MessageError . (("Property import failed: " ++ decn ++ ": ") ++) importOne base ((url, args), props) = medialibAddEntryEncoded xmms enc >>* do
src/Properties/Manager.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 5 Jul. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -126,10 +126,11 @@ let getByIter iter = do [n] <- treeModelGetPath store iter listStoreGetValue store n+ compBy :: Ord a => (Property -> a) -> TreeIter -> TreeIter -> IO Ordering compBy f a b = comparing f <$> getByIter a <*> getByIter b - treeSortableSetDefaultSortFunc sorted $ compBy (map toLower . propName)+ treeSortableSetDefaultSortFunc sorted $ Just $ compBy (map toLower . propName) treeSortableSetSortFunc sorted 0 $ compBy (map toLower . propName) treeSortableSetSortFunc sorted 1 $ compBy (map toLower . propKey) treeSortableSetSortFunc sorted 2 $ compBy (fromEnum . propType)@@ -288,7 +289,8 @@ tableSetColSpacings table 15 tableSetRowSpacings table 5 - let addPair m w b = do+ let addPair :: WidgetClass w => String -> w -> Int -> IO ()+ addPair m w b = do l <- labelNewWithMnemonic m miscSetAlignment l 0.0 0.5 labelSetMnemonicWidget l w
src/Properties/Model.hs view
@@ -25,11 +25,12 @@ , propertyStore , getProperties , setProperties- , onProperties+ , propertiesGeneration ) where import Prelude hiding (lookup) +import Control.Concurrent.STM import Control.Concurrent.MVar import Data.Map (Map)@@ -39,20 +40,18 @@ import Context import Config-import Handler-import Utils import Properties.Property data Model- = Model { mMap :: MVar (Map String Property)- , mStore :: ListStore Property- , mOnProperties :: HandlerMVar ()+ = Model { mMap :: MVar (Map String Property)+ , mStore :: ListStore Property+ , mGeneration :: TVar Integer } -propertyMap = mMap context-propertyStore = mStore context-onProperties = onHandler $ mOnProperties context+propertyMap = mMap context+propertyStore = mStore context+propertiesGeneration = mGeneration context initModel = do@@ -64,14 +63,13 @@ return ?context initContext = do- npmap <- newMVar $ mkMap builtinProperties- -- The store will be populated in loadProperties.- store <- listStoreNewDND [] Nothing Nothing- onprops <- makeHandlerMVar+ npmap <- newMVar $ mkMap builtinProperties+ store <- listStoreNewDND [] Nothing Nothing+ generation <- newTVarIO 0 return $ augmentContext- Model { mMap = npmap- , mStore = store- , mOnProperties = onprops+ Model { mMap = npmap+ , mStore = store+ , mGeneration = generation } property name =@@ -96,7 +94,9 @@ let m = mkMap props in return (m, Map.elems m)) writeConfig "properties.conf" props- onProperties $ invoke ()+ atomically $ do+ g <- readTVar propertiesGeneration+ writeTVar propertiesGeneration $ g + 1 mkMap = Map.fromList . map (\p -> (propName p, p))
src/Properties/Order.hs view
@@ -18,6 +18,7 @@ -- {-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module Properties.Order ( OrderDialog
src/Properties/View.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 22 Mar. 2010 ----- Copyright (C) 2009-2010 Oleg Belozeorov+-- Copyright (C) 2009-2011 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@@ -112,7 +112,7 @@ panedPack1 paned scroll True False filter <- treeModelFilterNew propertyStore []- treeModelFilterSetVisibleFunc filter $ Just $ \iter -> do+ treeModelFilterSetVisibleFunc filter $ \iter -> do [n] <- treeModelGetPath propertyStore iter prop <- listStoreGetValue propertyStore n seld <- readIORef selected
+ src/Registry.hs view
@@ -0,0 +1,92 @@+-- -*-haskell-*-+-- Vision (for the Voice): an XMMS2 client.+--+-- Author: Oleg Belozeorov+-- Created: 13 Jul. 2011+--+-- Copyright (C) 2011 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 MultiParamTypeClasses,+ FlexibleInstances,+ FlexibleContexts,+ OverlappingInstances,+ TypeOperators,+ DeriveDataTypeable,+ UndecidableInstances,+ ImplicitParams,+ StandaloneDeriving #-}++module Registry+ ( EnvM+ , runIn+ , startRegistry+ , registryEnv+ , RegistryEnvOp+ , addEnv+ , getEnv+ ) where++import Control.Monad.Trans+import Control.Monad.EnvIO++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Control.Concurrent.STM++import Data.Typeable+import Data.Dynamic+import Data.Env+++deriving instance Typeable2 Env++data Ix = Ix deriving Typeable++type EnvMap = TVar (IntMap Dynamic)++registryEnv :: Extract Ix EnvMap+registryEnv = Extract++class (EnvM Ix EnvMap m) => RegistryM m+instance (EnvM Ix EnvMap m) => RegistryM m++startRegistry f = do+ v <- newTVarIO $ IntMap.empty+ runEnvIO (addEnv Ix v >> f) $ build () $ mkEnv Ix v++class (RegistryM m, Typeable ix, Typeable a) => RegistryEnvOp ix a m+instance (RegistryM m, Typeable ix, Typeable a) => RegistryEnvOp ix a m++addEnv :: RegistryEnvOp ix a m => ix -> a -> m ()+addEnv ix r = do+ let val = mkEnv ix r+ var <- envx Ix+ liftIO $ do+ key <- typeRepKey $ typeOf val+ atomically $ do+ map <- readTVar var+ writeTVar var $ IntMap.insert key (toDyn val) map++getEnv :: RegistryEnvOp ix a m => Extract ix a -> m (Maybe (Env ix a))+getEnv spec = do+ var <- envx Ix+ liftIO $ do+ key <- typeRepKey $ typeOf $ env spec+ atomically $ do+ map <- readTVar var+ case IntMap.lookup key map of+ Nothing -> return Nothing+ Just dv -> return $ fromDynamic dv+ where env :: Extract ix a -> Env ix a+ env = const undefined
src/UI.hs view
@@ -36,9 +36,11 @@ , actions , bindAction , bindActions+ , informUser ) where import Control.Applicative+import Control.Monad.Trans import Data.Maybe @@ -55,6 +57,8 @@ , uManager :: UIManager , uActionGroup :: ActionGroup , uWindowGroup :: WindowGroup+ , uInfoBar :: InfoBar+ , uInfoText :: Label } window = uWindow context@@ -62,7 +66,10 @@ uiManager = uManager context uiActionGroup = uActionGroup context windowGroup = uWindowGroup context+infoBar = uInfoBar context+infoText = uInfoText context + setWindowTitle = windowSetTitle window addUIActions = actionGroupAddActions uiActionGroup insertActionGroup = uiManagerInsertActionGroup uiManager@@ -82,19 +89,27 @@ , ("about", showAbout window) ] + window `on` keyPressEvent $ tryEvent $ do+ [] <- eventModifier+ "Escape" <- eventKeyName+ liftIO $ infoBarEmitResponse infoBar dismiss+ return context makeUI builder = do- window <- builderGetObject builder castToWindow "main-window"- contents <- builderGetObject builder castToVBox "contents"- uiManager <- builderGetObject builder castToUIManager "ui-manager"- uiActionGroup <- builderGetObject builder castToActionGroup "ui-actions"- windowGroup <- windowGroupNew+ window <- builderGetObject builder castToWindow "main-window"+ contents <- builderGetObject builder castToVBox "contents"+ uiManager <- builderGetObject builder castToUIManager "ui-manager"+ uiActionGroup <- builderGetObject builder castToActionGroup "ui-actions"+ windowGroup <- windowGroupNew+ (infoBar, infoText) <- makeInfoBar builder return UI { uWindow = window , uContents = contents , uManager = uiManager , uActionGroup = uiActionGroup , uWindowGroup = windowGroup+ , uInfoBar = infoBar+ , uInfoText = infoText } makeBuilder name = do@@ -121,3 +136,26 @@ Just a -> Just <$> on (castToAction a) actionActivated func Nothing -> return Nothing +informUser t m = do+ infoBar `set` [ infoBarMessageType := t ]+ labelSetMarkup infoText m+ widgetSetNoShowAll infoBar False+ widgetShowAll infoBar++makeInfoBar builder = do+ infoBar <- builderGetObject builder castToInfoBar "info-bar"+ widgetSetNoShowAll infoBar True+ infoBarAddButton infoBar "Dismiss" dismiss+ infoBarSetDefaultResponse infoBar dismiss+ infoBar `on` infoBarResponse $ const $ widgetHide infoBar+ infoBar `on` infoBarClose $ widgetHide infoBar++ infoText <- labelNew Nothing+ miscSetAlignment infoText 0.0 0.5+ labelSetUseMarkup infoText True+ boxPackStartDefaults infoBar infoText+ boxReorderChild infoBar infoText 0++ return (infoBar, infoText)++dismiss = 0
src/Utils.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 17 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -18,10 +18,7 @@ -- module Utils- ( HandlerMVar- , makeHandlerMVar- , onHandler- , encodeURL+ ( encodeURL , decodeURL , trd , trim@@ -56,15 +53,7 @@ import XMMS2.Client -import Handler --type HandlerMVar a = MVar (Handler IO a)--makeHandlerMVar = newMVar make--onHandler = modifyMVar- encodeURL = encodeURL' . encodeString encodeURL' [] = [] encodeURL' (' ':cs) = '+' : encodeURL' cs@@ -98,8 +87,6 @@ trim = f . f where f = reverse . dropWhile isSpace -bracket_ f g = bracket f (const g) . const- catchResult def conv = (conv <$> result) `catch` \(_ :: XMMSException) -> return def @@ -132,6 +119,7 @@ SingleClick <- eventClick stamp <- eventTime setCursor+ liftIO $ widgetGrabFocus view liftIO $ menuPopup popup $ Just (RightButton, stamp) dialogAddButtonCR dialog label response = do
src/Vision.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 11 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -20,6 +20,9 @@ module Main where +import Control.Concurrent+import Control.Monad.Trans+ import Graphics.UI.Gtk import Environment@@ -34,47 +37,45 @@ import Location import Collection import Playlist+import Registry main = do initGUI - context <- initEnvironment- let ?context = context-- context <- initAbout- let ?context = context+ timeoutAdd (yield >> return True) 100 - context <- initXMMS- let ?context = context+ startRegistry $ do+ context <- liftIO $ initEnvironment+ let ?context = context - context <- initMedialib- let ?context = context+ context <- liftIO $ initAbout+ let ?context = context - context <- initProperties- let ?context = context+ context <- liftIO $ initXMMS+ let ?context = context - context <- initPlayback- let ?context = context+ context <- liftIO $ initMedialib+ let ?context = context - context <- initVolume- let ?context = context+ context <- liftIO $ initProperties+ let ?context = context - context <- initPlaytime- let ?context = context+ context <- liftIO $ initPlayback+ let ?context = context - context <- initClipboard- let ?context = context+ initVolume+ initPlaytime+ initClipboard - context <- initLocation- let ?context = context+ context <- liftIO $ initLocation+ let ?context = context - context <- initCollection- let ?context = context+ initCollection - context <- initPlaylist- let ?context = context+ context <- liftIO $ initPlaylist+ let ?context = context - showPlaylist+ showPlaylist mainGUI
src/Volume.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 22 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -17,76 +17,83 @@ -- General Public License for more details. -- +{-# LANGUAGE DeriveDataTypeable #-}+ module Volume ( initVolume+ , volumeEnv , makeVolumeControl ) where +import Control.Monad import Control.Monad.Trans+import Control.Monad.EnvIO +import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TGVar+ import qualified Data.Map as Map+import Data.Typeable+import Data.Env import Graphics.UI.Gtk hiding (add, remove) import XMMS2.Client import XMMS-import Handler import Utils-import Context+import Registry -data Volume- = Volume { vAdj :: Adjustment- , vCid :: ConnectId Adjustment }+data Ix = Ix deriving (Typeable)+deriving instance Typeable Adjustment -adj = vAdj context-cId = vCid context+volumeEnv :: Extract Ix Adjustment+volumeEnv = Extract initVolume = do- context <- initContext- let ?context = context-- onServerConnectionAdd . ever $ \conn ->- if conn- then do- playbackVolumeGet xmms >>* do- handleVolume- liftIO $ broadcastPlaybackVolumeChanged xmms >>* do- handleVolume- persist- signalUnblock cId- else do- signalBlock cId- withoutVolumeChange $ adjustmentSetValue adj 0-- return ?context+ adj <- liftIO $ adjustmentNew 0 0 100 5 5 0+ addEnv Ix adj + liftIO $ do+ cId <- adj `onValueChanged` do+ vol <- adjustmentGetValue adj+ setVolume $ round vol -initContext = do- adj <- adjustmentNew 0 0 100 5 5 0- cId <- adj `onValueChanged` do- vol <- adjustmentGetValue adj- setVolume $ round vol- return $ augmentContext- Volume { vAdj = adj, vCid = cId }+ xcW <- atomically $ newTGWatch connectedV+ forkIO $ forever $ do+ conn <- atomically $ watch xcW+ if conn+ then do+ playbackVolumeGet xmms >>* do+ handleVolume adj cId+ liftIO $ broadcastPlaybackVolumeChanged xmms >>* do+ handleVolume adj cId+ persist+ else withoutVolumeChange cId $ adjustmentSetValue adj 0 + return () makeVolumeControl = do- view <- hScaleNew adj- scaleSetDrawValue view False- rangeSetUpdatePolicy view UpdateContinuous- widgetSetCanFocus view False-- id <- onServerConnectionAdd . ever $ widgetSetSensitive view- view `onDestroy` onServerConnection (remove id)+ adj <- envx Ix+ liftIO $ do+ view <- hScaleNew adj+ scaleSetDrawValue view False+ rangeSetUpdatePolicy view UpdateContinuous+ widgetSetCanFocus view False - return view+ xcW <- atomically $ newTGWatch connectedV+ tid <- forkIO $ forever $ do+ conn <- atomically $ watch xcW+ widgetSetSensitive view conn+ view `onDestroy` killThread tid + return view -handleVolume = do+handleVolume adj cId = do vol <- catchResult 0 (maximum . Map.elems)- liftIO $ withoutVolumeChange $+ liftIO $ withoutVolumeChange cId $ adjustmentSetValue adj $ fromIntegral vol setVolume vol =@@ -94,5 +101,5 @@ vols <- catchResult Map.empty id liftIO $ mapM_ (flip (playbackVolumeSet xmms) vol) $ Map.keys vols -withoutVolumeChange =+withoutVolumeChange cId = bracket_ (signalBlock cId) (signalUnblock cId)
src/XMMS.hs view
@@ -4,7 +4,7 @@ -- Author: Oleg Belozeorov -- Created: 18 Jun. 2010 ----- Copyright (C) 2010 Oleg Belozeorov+-- Copyright (C) 2010, 2011 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@@ -17,45 +17,40 @@ -- General Public License for more details. -- +{-# LANGUAGE UndecidableInstances #-}+ module XMMS ( xmms , initXMMS , connected- , onServerConnection- , onServerConnectionAdd+ , connectedV+ , XMMSCC ) where -import Prelude hiding (init)-import Control.Concurrent.MVar+import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TGVar -import Graphics.UI.Gtk hiding (add)+import Graphics.UI.Gtk import XMMS2.Client import XMMS2.Client.Glib import Environment-import Handler-import Utils import Context -data State- = State { sConnected :: Bool }--makeState = State { sConnected = False }-- data XMMS- = XMMS { xXMMS :: Connection- , xOnServerConnection :: HandlerMVar Bool- , xState :: MVar State+ = XMMS { xXMMS :: Connection+ , xConnected :: TGVar Bool } -xmms = xXMMS context-onServerConnection = onHandler (xOnServerConnection context)-state = xState context+class ContextClass XMMS c => XMMSCC c+instance ContextClass XMMS c => XMMSCC c -connected = withMVar state $ return . sConnected+xmms = xXMMS context+connectedV = xConnected context+connected = readTGVarIO connectedV initXMMS = do context <- initContext@@ -67,13 +62,11 @@ initContext = do- xmms <- init "Vision"- onServerConnection <- makeHandlerMVar- state <- newMVar makeState+ xmms <- XMMS2.Client.init "Vision"+ connected <- atomically $ newTGVar False return $ augmentContext- XMMS { xXMMS = xmms- , xOnServerConnection = onServerConnection- , xState = state+ XMMS { xXMMS = xmms+ , xConnected = connected } scheduleTryConnect = timeoutAdd tryConnect@@ -84,20 +77,17 @@ then do disconnectCallbackSet xmms disconnectCallback mainLoopGMainInit xmms- modifyMVar_ state $ \s -> return s { sConnected = True }- onServerConnection $ invoke True+ setConnected True+ yield return False else do scheduleTryConnect 1000 return False disconnectCallback = do- modifyMVar_ state $ \s -> return s { sConnected = False }- onServerConnection $ invoke False+ setConnected False+ yield scheduleTryConnect 1000 return () -onServerConnectionAdd f = do- id <- onServerConnection . add $ f- f =<< connected- return id+setConnected = atomically . writeTGVar connectedV
ui/collection-browser.glade view
@@ -11,27 +11,6 @@ </object> </child> <child>- <object class="GtkAction" id="new-window">- <property name="label">_New window</property>- <property name="stock_id">gtk-new</property>- </object>- <accelerator key="n" modifiers="GDK_CONTROL_MASK"/>- </child>- <child>- <object class="GtkAction" id="edit-filter">- <property name="label">_Edit filter</property>- <property name="stock_id">gtk-edit</property>- </object>- <accelerator key="l" modifiers="GDK_CONTROL_MASK"/>- </child>- <child>- <object class="GtkAction" id="all-media">- <property name="label">A_ll media</property>- <property name="stock_id">gtk-new</property>- </object>- <accelerator key="u" modifiers="GDK_CONTROL_MASK"/>- </child>- <child> <object class="GtkAction" id="close"> <property name="label">_Close window</property> <property name="stock_id">gtk-close</property>@@ -90,13 +69,6 @@ <child> <object class="GtkActionGroup" id="server-actions"> <child>- <object class="GtkAction" id="browse-in-new-window">- <property name="label">_Browse in new window</property>- <property name="stock_id">gtk-open</property>- </object>- <accelerator key="Return" modifiers="GDK_CONTROL_MASK"/>- </child>- <child> <object class="GtkAction" id="save-collection"> <property name="label">_Save collection…</property> <property name="stock_id">gtk-save</property>@@ -109,8 +81,8 @@ </object> </child> <child>- <object class="GtkAction" id="delete-collection">- <property name="label">_Delete collection</property>+ <object class="GtkAction" id="delete-collections">+ <property name="label">_Delete collections</property> <property name="stock_id">gtk-delete</property> </object> </child>@@ -119,13 +91,13 @@ <property name="label">_Add to playlist</property> <property name="stock_id">gtk-add</property> </object>- <accelerator key="p" modifiers="GDK_CONTROL_MASK"/>+ <accelerator key="Return" modifiers="GDK_CONTROL_MASK"/> </child> <child> <object class="GtkAction" id="replace-playlist"> <property name="label">_Replace playlist</property> </object>- <accelerator key="p" modifiers="GDK_CONTROL_MASK | GDK_SHIFT_MASK"/>+ <accelerator key="Return" modifiers="GDK_CONTROL_MASK | GDK_SHIFT_MASK"/> </child> <child> <object class="GtkAction" id="coll-add-to-playlist">@@ -197,17 +169,12 @@ <menubar name="menubar"> <placeholder name="entries"> <menu action="collection">- <menuitem action="new-window"/>- <menuitem action="edit-filter"/>- <menuitem action="browse-in-new-window"/>- <menuitem action="all-media"/>+ <menuitem action="add-to-playlist"/>+ <menuitem action="replace-playlist"/> <separator/> <menuitem action="save-collection"/> <menuitem action="rename-collection"/>- <menuitem action="delete-collection"/>- <separator/>- <menuitem action="add-to-playlist"/>- <menuitem action="replace-playlist"/>+ <menuitem action="delete-collections"/> <separator/> <menuitem action="close"/> <menuitem action="quit"/>@@ -218,10 +185,12 @@ <menuitem action="select-all"/> <menuitem action="invert-selection"/> </menu>+ <!-- <menu action="view"> <menuitem action="configure-columns"/> <menuitem action="configure-ordering"/> </menu>+ --> <menu action="properties"> <menuitem action="edit-properties"/> <menuitem action="export-properties"/>@@ -234,9 +203,9 @@ </menu> </placeholder> </menubar>- <popup action="collection-popup">- <menuitem action="coll-add-to-playlist"/>- <menuitem action="coll-replace-playlist"/>+ <popup action="list-popup">+ <menuitem action="add-to-playlist"/>+ <menuitem action="replace-playlist"/> <separator/> <menuitem action="copy"/> <separator/>@@ -244,15 +213,23 @@ <menuitem action="invert-selection"/> <separator/> <menuitem action="edit-properties"/>- </popup>- <popup action="list-popup">- <menuitem action="list-add-to-playlist"/>- <menuitem action="list-replace-playlist"/> <separator/>+ <menuitem action="save-collection"/> <menuitem action="rename-collection"/>- <menuitem action="delete-collection"/>+ <menuitem action="delete-collections"/>+ </popup>+ <popup action="view-popup">+ <menuitem action="add-to-playlist"/>+ <menuitem action="replace-playlist"/> <separator/>- <menuitem action="browse-in-new-window"/>+ <menuitem action="copy"/>+ <separator/>+ <menuitem action="select-all"/>+ <menuitem action="invert-selection"/>+ <separator/>+ <menuitem action="edit-properties"/>+ <separator/>+ <menuitem action="save-collection"/> </popup> </ui> </object>@@ -270,80 +247,19 @@ </packing> </child> <child>- <object class="GtkHPaned" id="paned">+ <object class="GtkVBox" id="views"> <property name="visible">True</property>- <property name="can_focus">True</property>- <child>- <object class="GtkScrolledWindow" id="list-scroll">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="hscrollbar_policy">automatic</property>- <property name="vscrollbar_policy">automatic</property>- <property name="shadow_type">in</property>- <child>- <object class="GtkTreeView" id="list-view">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="headers_visible">False</property>- <property name="headers_clickable">False</property>- </object>- </child>- </object>- <packing>- <property name="resize">False</property>- <property name="shrink">True</property>- </packing>- </child>- <child>- <object class="GtkVBox" id="collection-box">- <property name="visible">True</property>- <property name="spacing">5</property>- <child>- <object class="GtkEntry" id="filter-entry">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="invisible_char">●</property>- <property name="primary_icon_stock">gtk-clear</property>- <property name="primary_icon_activatable">True</property>- <property name="primary_icon_tooltip_text">Clear filter</property>- <property name="secondary_icon_stock">gtk-jump-to</property>- <property name="secondary_icon_activatable">True</property>- <property name="secondary_icon_tooltip_text">Apply filter to selected collection</property>- </object>- <packing>- <property name="expand">False</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkScrolledWindow" id="collection-scroll">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="hscrollbar_policy">automatic</property>- <property name="vscrollbar_policy">automatic</property>- <property name="shadow_type">in</property>- <child>- <object class="GtkTreeView" id="collection-view">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="headers_clickable">False</property>- <property name="rules_hint">True</property>- </object>- </child>- </object>- <packing>- <property name="position">1</property>- </packing>- </child>- </object>- <packing>- <property name="resize">True</property>- <property name="shrink">False</property>- </packing>- </child> </object> <packing>+ <property name="expand">True</property> <property name="position">1</property>+ </packing>+ </child>+ <child>+ <object class="GtkInfoBar" id="info-bar"/>+ <packing>+ <property name="position">2</property>+ <property name="expand">False</property> </packing> </child> </object>
ui/location-browser.glade view
@@ -193,6 +193,13 @@ <property name="position">2</property> </packing> </child>+ <child>+ <object class="GtkInfoBar" id="info-bar"/>+ <packing>+ <property name="position">3</property>+ <property name="expand">False</property>+ </packing>+ </child> </object> </child> </object>
ui/playlist.glade view
@@ -299,13 +299,20 @@ </packing> </child> <child>+ <object class="GtkInfoBar" id="info-bar"/>+ <packing>+ <property name="position">2</property>+ <property name="expand">False</property>+ </packing>+ </child>+ <child> <object class="GtkToolbar" constructor="ui-manager" id="playbar"> <property name="visible">True</property> <property name="toolbar_style">icons</property> </object> <packing> <property name="expand">False</property>- <property name="position">2</property>+ <property name="position">3</property> </packing> </child> </object>
vision.cabal view
@@ -1,9 +1,9 @@ name: vision-version: 0.0.4.0+version: 0.0.5.0 author: Oleg Belozeorov maintainer: Oleg Belozeorov <upwawet@gmail.com>-copyright: (C) 2010 Oleg Belozeorov+copyright: (C) 2010, 2011 Oleg Belozeorov license: GPL-3 license-file: COPYING @@ -20,14 +20,19 @@ extra-tmp-files: config.status, config.log, autom4te.cache, hlint.out extra-source-files: configure.ac, configure,+ src/Control/Monad/Makefile.in,+ src/Control/Concurrent/Makefile.in,+ src/Control/Concurrent/STM/Makefile.in,+ src/Control/Makefile.in,+ src/Playlist/Makefile.in,+ src/Playlist/Format/Makefile.in,+ src/Makefile.in, src/Properties/Makefile.in, src/Properties/Editor/Makefile.in,- src/Makefile.in,- src/Location/Makefile.in,- src/Playlist/Format/Makefile.in,- src/Playlist/Makefile.in,- src/Collection/Makefile.in, src/Collection/List/Makefile.in,+ src/Collection/Makefile.in,+ src/Data/Makefile.in,+ src/Location/Makefile.in, Makefile.in, ui/Makefile.in data-files: ui/*.xml,@@ -35,9 +40,9 @@ executable vision main-is: Vision.hs- other-modules: Handler,- Utils,+ other-modules: Utils, Context,+ Registry, XMMS, Environment, Medialib,@@ -66,6 +71,7 @@ Index, Location, Location.History,+ Location.PathComp, Location.Model, Location.View, Location.DnD,@@ -75,12 +81,15 @@ Collection.List, Collection.List.Model, Collection.List.View,+ Collection.Actions,+ Collection.ScrollBox,+ Collection.PropFlt,+ Collection.Tracks,+ Collection.ComboModel,+ Collection.Combo,+ Collection.Select,+ Collection.Utils, Collection.Common,- Collection.Model,- Collection.View,- Collection.Control,- Collection.DnD,- Collection.UI, Playlist, Playlist.Model, Playlist.View,@@ -95,14 +104,21 @@ Playlist.Format, Playlist.Format.Format, Playlist.Format.Parser,- Playlist.Format.Config+ Playlist.Format.Config,+ Control.Concurrent.STM.TWatch,+ Control.Concurrent.STM.TGVar,+ Control.Concurrent.STM.Watch,+ Control.Monad.ToIO,+ Control.Monad.W,+ Control.Monad.EnvIO,+ Data.Env hs-source-dirs: src- build-depends: base >= 4 && < 5, xmms2-client >= 0.0.5.0,- xmms2-client-glib >= 0.0.5.0,+ build-depends: base >= 4 && < 5, xmms2-client >= 0.0.7.0,+ xmms2-client-glib >= 0.0.7.0, gtk, containers, mtl, utf8-string, filepath, directory, glib, array,- MonadCatchIO-mtl, json, parsec >= 3.0.1,- url+ MonadCatchIO-transformers, json, parsec >= 3.0.1,+ url, stm, PSQueue extensions: ImplicitParams, NoMonomorphismRestriction, FlexibleContexts, FlexibleInstances, TypeFamilies, ScopedTypeVariables,@@ -118,4 +134,4 @@ source-repository this type: git location: git://github.com/upwawet/vision.git- tag: v0.0.4.0+ tag: v0.0.5.0