diff --git a/configure b/configure --- a/configure +++ b/configure @@ -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` 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 diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -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 diff --git a/src/About.hs b/src/About.hs --- a/src/About.hs +++ b/src/About.hs @@ -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 diff --git a/src/Clipboard.hs b/src/Clipboard.hs --- a/src/Clipboard.hs +++ b/src/Clipboard.hs @@ -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 diff --git a/src/Collection.hs b/src/Collection.hs --- a/src/Collection.hs +++ b/src/Collection.hs @@ -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 diff --git a/src/Collection/Actions.hs b/src/Collection/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Collection/Actions.hs @@ -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 () + } diff --git a/src/Collection/Combo.hs b/src/Collection/Combo.hs new file mode 100644 --- /dev/null +++ b/src/Collection/Combo.hs @@ -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 + diff --git a/src/Collection/ComboModel.hs b/src/Collection/ComboModel.hs new file mode 100644 --- /dev/null +++ b/src/Collection/ComboModel.hs @@ -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 diff --git a/src/Collection/Common.hs b/src/Collection/Common.hs --- a/src/Collection/Common.hs +++ b/src/Collection/Common.hs @@ -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 diff --git a/src/Collection/Control.hs b/src/Collection/Control.hs deleted file mode 100644 --- a/src/Collection/Control.hs +++ /dev/null @@ -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 diff --git a/src/Collection/DnD.hs b/src/Collection/DnD.hs deleted file mode 100644 --- a/src/Collection/DnD.hs +++ /dev/null @@ -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 () - diff --git a/src/Collection/List.hs b/src/Collection/List.hs --- a/src/Collection/List.hs +++ b/src/Collection/List.hs @@ -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 diff --git a/src/Collection/List/Model.hs b/src/Collection/List/Model.hs --- a/src/Collection/List/Model.hs +++ b/src/Collection/List/Model.hs @@ -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) diff --git a/src/Collection/List/View.hs b/src/Collection/List/View.hs --- a/src/Collection/List/View.hs +++ b/src/Collection/List/View.hs @@ -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 diff --git a/src/Collection/Model.hs b/src/Collection/Model.hs deleted file mode 100644 --- a/src/Collection/Model.hs +++ /dev/null @@ -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" diff --git a/src/Collection/PropFlt.hs b/src/Collection/PropFlt.hs new file mode 100644 --- /dev/null +++ b/src/Collection/PropFlt.hs @@ -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 diff --git a/src/Collection/ScrollBox.hs b/src/Collection/ScrollBox.hs new file mode 100644 --- /dev/null +++ b/src/Collection/ScrollBox.hs @@ -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 diff --git a/src/Collection/Select.hs b/src/Collection/Select.hs new file mode 100644 --- /dev/null +++ b/src/Collection/Select.hs @@ -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 diff --git a/src/Collection/Tracks.hs b/src/Collection/Tracks.hs new file mode 100644 --- /dev/null +++ b/src/Collection/Tracks.hs @@ -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 diff --git a/src/Collection/UI.hs b/src/Collection/UI.hs deleted file mode 100644 --- a/src/Collection/UI.hs +++ /dev/null @@ -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 diff --git a/src/Collection/Utils.hs b/src/Collection/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Collection/Utils.hs @@ -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 diff --git a/src/Collection/View.hs b/src/Collection/View.hs deleted file mode 100644 --- a/src/Collection/View.hs +++ /dev/null @@ -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) - - diff --git a/src/Context.hs b/src/Context.hs --- a/src/Context.hs +++ b/src/Context.hs @@ -19,8 +19,13 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, + FlexibleContexts, OverlappingInstances, - TypeOperators #-} + TypeOperators, + DeriveDataTypeable, + UndecidableInstances, + ImplicitParams, + StandaloneDeriving #-} module Context ( ContextClass diff --git a/src/Control/Concurrent/Makefile.in b/src/Control/Concurrent/Makefile.in new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Makefile.in @@ -0,0 +1,1 @@ +include @abs_top_srcdir@/Makefile diff --git a/src/Control/Concurrent/STM/Makefile.in b/src/Control/Concurrent/STM/Makefile.in new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/Makefile.in @@ -0,0 +1,1 @@ +include @abs_top_srcdir@/Makefile diff --git a/src/Control/Concurrent/STM/TGVar.hs b/src/Control/Concurrent/STM/TGVar.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TGVar.hs @@ -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 diff --git a/src/Control/Concurrent/STM/TWatch.hs b/src/Control/Concurrent/STM/TWatch.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TWatch.hs @@ -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 diff --git a/src/Control/Concurrent/STM/Watch.hs b/src/Control/Concurrent/STM/Watch.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/Watch.hs @@ -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 + diff --git a/src/Control/Makefile.in b/src/Control/Makefile.in new file mode 100644 --- /dev/null +++ b/src/Control/Makefile.in @@ -0,0 +1,1 @@ +include @abs_top_srcdir@/Makefile diff --git a/src/Control/Monad/EnvIO.hs b/src/Control/Monad/EnvIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/EnvIO.hs @@ -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 diff --git a/src/Control/Monad/Makefile.in b/src/Control/Monad/Makefile.in new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Makefile.in @@ -0,0 +1,1 @@ +include @abs_top_srcdir@/Makefile diff --git a/src/Control/Monad/ToIO.hs b/src/Control/Monad/ToIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/ToIO.hs @@ -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 diff --git a/src/Control/Monad/W.hs b/src/Control/Monad/W.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/W.hs @@ -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 $> diff --git a/src/Data/Env.hs b/src/Data/Env.hs new file mode 100644 --- /dev/null +++ b/src/Data/Env.hs @@ -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 + diff --git a/src/Data/Makefile.in b/src/Data/Makefile.in new file mode 100644 --- /dev/null +++ b/src/Data/Makefile.in @@ -0,0 +1,1 @@ +include @abs_top_srcdir@/Makefile diff --git a/src/Handler.hs b/src/Handler.hs deleted file mode 100644 --- a/src/Handler.hs +++ /dev/null @@ -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 diff --git a/src/Index.hs b/src/Index.hs --- a/src/Index.hs +++ b/src/Index.hs @@ -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 diff --git a/src/Location/Control.hs b/src/Location/Control.hs --- a/src/Location/Control.hs +++ b/src/Location/Control.hs @@ -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 ++ ": " ++ escapeMarkup t ++ "" 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 diff --git a/src/Location/Model.hs b/src/Location/Model.hs --- a/src/Location/Model.hs +++ b/src/Location/Model.hs @@ -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 diff --git a/src/Location/PathComp.hs b/src/Location/PathComp.hs new file mode 100644 --- /dev/null +++ b/src/Location/PathComp.hs @@ -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) "" + diff --git a/src/Location/UI.hs b/src/Location/UI.hs --- a/src/Location/UI.hs +++ b/src/Location/UI.hs @@ -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" diff --git a/src/Location/View.hs b/src/Location/View.hs --- a/src/Location/View.hs +++ b/src/Location/View.hs @@ -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) diff --git a/src/Medialib.hs b/src/Medialib.hs --- a/src/Medialib.hs +++ b/src/Medialib.hs @@ -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 diff --git a/src/Playback.hs b/src/Playback.hs --- a/src/Playback.hs +++ b/src/Playback.hs @@ -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 diff --git a/src/Playlist.hs b/src/Playlist.hs --- a/src/Playlist.hs +++ b/src/Playlist.hs @@ -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 diff --git a/src/Playlist/Edit.hs b/src/Playlist/Edit.hs --- a/src/Playlist/Edit.hs +++ b/src/Playlist/Edit.hs @@ -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 () - diff --git a/src/Playlist/Format.hs b/src/Playlist/Format.hs --- a/src/Playlist/Format.hs +++ b/src/Playlist/Format.hs @@ -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 diff --git a/src/Playlist/Format/Config.hs b/src/Playlist/Format/Config.hs --- a/src/Playlist/Format/Config.hs +++ b/src/Playlist/Format/Config.hs @@ -18,6 +18,7 @@ -- {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module Playlist.Format.Config ( FormatView diff --git a/src/Playlist/Index.hs b/src/Playlist/Index.hs --- a/src/Playlist/Index.hs +++ b/src/Playlist/Index.hs @@ -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) diff --git a/src/Playlist/Model.hs b/src/Playlist/Model.hs --- a/src/Playlist/Model.hs +++ b/src/Playlist/Model.hs @@ -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 } - diff --git a/src/Playlist/Search.hs b/src/Playlist/Search.hs --- a/src/Playlist/Search.hs +++ b/src/Playlist/Search.hs @@ -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) diff --git a/src/Playlist/UI.hs b/src/Playlist/UI.hs --- a/src/Playlist/UI.hs +++ b/src/Playlist/UI.hs @@ -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 = diff --git a/src/Playlist/Update.hs b/src/Playlist/Update.hs --- a/src/Playlist/Update.hs +++ b/src/Playlist/Update.hs @@ -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 diff --git a/src/Playlist/View.hs b/src/Playlist/View.hs --- a/src/Playlist/View.hs +++ b/src/Playlist/View.hs @@ -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 = diff --git a/src/Playtime.hs b/src/Playtime.hs --- a/src/Playtime.hs +++ b/src/Playtime.hs @@ -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 } diff --git a/src/Properties.hs b/src/Properties.hs --- a/src/Properties.hs +++ b/src/Properties.hs @@ -27,7 +27,7 @@ , property , showPropertyManager , showPropertyEditor - , onProperties + , propertiesGeneration , showPropertyExport , showPropertyImport , module Properties.View diff --git a/src/Properties/Editor/Model.hs b/src/Properties/Editor/Model.hs --- a/src/Properties/Editor/Model.hs +++ b/src/Properties/Editor/Model.hs @@ -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 diff --git a/src/Properties/Editor/UI.hs b/src/Properties/Editor/UI.hs --- a/src/Properties/Editor/UI.hs +++ b/src/Properties/Editor/UI.hs @@ -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 diff --git a/src/Properties/Impex.hs b/src/Properties/Impex.hs --- a/src/Properties/Impex.hs +++ b/src/Properties/Impex.hs @@ -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 diff --git a/src/Properties/Manager.hs b/src/Properties/Manager.hs --- a/src/Properties/Manager.hs +++ b/src/Properties/Manager.hs @@ -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 diff --git a/src/Properties/Model.hs b/src/Properties/Model.hs --- a/src/Properties/Model.hs +++ b/src/Properties/Model.hs @@ -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)) diff --git a/src/Properties/Order.hs b/src/Properties/Order.hs --- a/src/Properties/Order.hs +++ b/src/Properties/Order.hs @@ -18,6 +18,7 @@ -- {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module Properties.Order ( OrderDialog diff --git a/src/Properties/View.hs b/src/Properties/View.hs --- a/src/Properties/View.hs +++ b/src/Properties/View.hs @@ -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 diff --git a/src/Registry.hs b/src/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Registry.hs @@ -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 diff --git a/src/UI.hs b/src/UI.hs --- a/src/UI.hs +++ b/src/UI.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 diff --git a/src/Vision.hs b/src/Vision.hs --- a/src/Vision.hs +++ b/src/Vision.hs @@ -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 diff --git a/src/Volume.hs b/src/Volume.hs --- a/src/Volume.hs +++ b/src/Volume.hs @@ -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) diff --git a/src/XMMS.hs b/src/XMMS.hs --- a/src/XMMS.hs +++ b/src/XMMS.hs @@ -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 diff --git a/ui/collection-browser.glade b/ui/collection-browser.glade --- a/ui/collection-browser.glade +++ b/ui/collection-browser.glade @@ -11,27 +11,6 @@ - - _New window - gtk-new - - - - - - _Edit filter - gtk-edit - - - - - - A_ll media - gtk-new - - - - _Close window gtk-close @@ -90,13 +69,6 @@ - - _Browse in new window - gtk-open - - - - _Save collection… gtk-save @@ -109,8 +81,8 @@ - - _Delete collection + + _Delete collections gtk-delete @@ -119,13 +91,13 @@ _Add to playlist gtk-add - + _Replace playlist - + @@ -197,17 +169,12 @@ - - - - + + - - - - + @@ -218,10 +185,12 @@ + @@ -234,9 +203,9 @@ - - - + + + @@ -244,15 +213,23 @@ - - - - + - + + + + + - + + + + + + + + @@ -270,80 +247,19 @@ - + True - True - - - True - True - automatic - automatic - in - - - True - True - False - False - - - - - False - True - - - - - True - 5 - - - True - True - ● - gtk-clear - True - Clear filter - gtk-jump-to - True - Apply filter to selected collection - - - False - 0 - - - - - True - True - automatic - automatic - in - - - True - True - False - True - - - - - 1 - - - - - True - False - - + True 1 + + + + + + 2 + False diff --git a/ui/location-browser.glade b/ui/location-browser.glade --- a/ui/location-browser.glade +++ b/ui/location-browser.glade @@ -193,6 +193,13 @@ 2 + + + + 3 + False + + diff --git a/ui/playlist.glade b/ui/playlist.glade --- a/ui/playlist.glade +++ b/ui/playlist.glade @@ -299,13 +299,20 @@ + + + 2 + False + + + True icons False - 2 + 3 diff --git a/vision.cabal b/vision.cabal --- a/vision.cabal +++ b/vision.cabal @@ -1,9 +1,9 @@ name: vision -version: 0.0.4.0 +version: 0.0.5.0 author: Oleg Belozeorov maintainer: Oleg Belozeorov -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