vimus (empty) → 0.1.0
raw patch · 47 files changed
+5587/−0 lines, 47 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, containers, data-default, deepseq, directory, filepath, hspec, hspec-expectations, libmpd, mtl, old-locale, process, template-haskell, time, transformers, utf8-string, vimus, wcwidth
Files
- LICENSE +19/−0
- Setup.lhs +3/−0
- driver/Main.hs +5/−0
- ncursesw/src/Constant.hsc +26/−0
- ncursesw/src/Curses.chs +332/−0
- ncursesw/src/CursesInput.chs +76/−0
- ncursesw/src/CursesUtil.hs +21/−0
- ncursesw/src/Misc.chs +182/−0
- ncursesw/src/UI/Curses.hs +3/−0
- ncursesw/src/UI/Curses/Key.hsc +367/−0
- ncursesw/src/UI/Curses/Type.chs +18/−0
- ncursesw/src/cbits.c +42/−0
- ncursesw/src/mycurses.h +10/−0
- resource/default-mappings +65/−0
- resource/emacs-mappings +25/−0
- src/Command.hs +899/−0
- src/Command/Completion.hs +69/−0
- src/Command/Core.hs +175/−0
- src/Command/Help.hs +63/−0
- src/Command/Parser.hs +95/−0
- src/Command/Type.hs +32/−0
- src/Content.hs +62/−0
- src/Data/List/Pointed.hs +29/−0
- src/Data/List/Zipper.hs +74/−0
- src/Input.hs +240/−0
- src/Key.hs +212/−0
- src/Macro.hs +89/−0
- src/Option.hs +70/−0
- src/PlaybackState.hs +95/−0
- src/Queue.hs +27/−0
- src/Render.hs +93/−0
- src/Ruler.hs +45/−0
- src/Run.hs +281/−0
- src/Song.hs +74/−0
- src/Song/Format.hs +131/−0
- src/Tab.hs +146/−0
- src/Timer.hs +54/−0
- src/Type.hs +15/−0
- src/Util.hs +83/−0
- src/Vimus.hs +467/−0
- src/Widget/HelpWidget.hs +109/−0
- src/Widget/ListWidget.hs +347/−0
- src/Widget/TextWidget.hs +49/−0
- src/Widget/Type.hs +48/−0
- src/WindowLayout.hs +92/−0
- test/Spec.hs +1/−0
- vimus.cabal +127/−0
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2010-2014 `git shortlog`++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ driver/Main.hs view
@@ -0,0 +1,5 @@+module Main where+import qualified Run++main :: IO ()+main = Run.main
+ ncursesw/src/Constant.hsc view
@@ -0,0 +1,26 @@+module Constant where++import Foreign.C.Types++#include "mycurses.h"++------------------------------------------------------------------------+-- ncurses(3NCURSES)+------------------------------------------------------------------------+err, ok :: CInt+ok = (#const OK)+err = (#const ERR)++------------------------------------------------------------------------+-- color+------------------------------------------------------------------------++black, red, green, yellow, blue, magenta, cyan, white :: CShort+black = (#const COLOR_BLACK)+red = (#const COLOR_RED)+green = (#const COLOR_GREEN)+yellow = (#const COLOR_YELLOW)+blue = (#const COLOR_BLUE)+magenta = (#const COLOR_MAGENTA)+cyan = (#const COLOR_CYAN)+white = (#const COLOR_WHITE)
+ ncursesw/src/Curses.chs view
@@ -0,0 +1,332 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Curses (+ Status+, err+, ok+, module Misc+, module CursesInput+, module UI.Curses.Key+, addstr+, addnstr+, waddstr+, waddnstr+, mvaddstr+, mvaddnstr+, mvwaddstr+, mvwaddnstr++-- wchar functions+, mvwaddnwstr++-- TODO+, getmaxyx+, getbegyx+, stdscr+, refresh+, wrefresh+, initscr+, endwin+, isendwin+, getyx+, wdelch+, move+, werase+, wclrtoeol+, clrtoeol+, curs_set+, newwin+, delwin+, mvwin+, newpad+, prefresh+, mvwaddch+, waddch+-- , mytrace++-- inopts+, cbreak+, nocbreak+, echo+, noecho+, nl+, nonl+, halfdelay+, intrflush+, keypad+, meta+, nodelay+, raw+, noraw+, noqiflush+, qiflush+, notimeout+, timeout+, wtimeout+, Window+-- , typeahead+) where+++import Foreign.C.Types+import Foreign.C.String hiding (withCString)+import Foreign.Ptr (Ptr, castPtr)+import Foreign.C.String (CString)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Storable (peek)+import Data.Char (chr, ord)++import Foreign.Marshal.Utils (toBool, fromBool)++import Data.ByteString.UTF8 as UTF8+import Data.ByteString.Char8 as Char8++import Misc hiding (cFromBool)+import CursesUtil+import UI.Curses.Key+import CursesInput+++{# import UI.Curses.Type #}++#include "mycurses.h"++------------------------------------------------------------------------+-- default marshaller implementations+------------------------------------------------------------------------+withCString :: String -> (CString -> IO a) -> IO a+withCString = Char8.useAsCString . UTF8.fromString++------------------------------------------------------------------------+-- initscr(3NCURSES)+------------------------------------------------------------------------++-- NOTE: newterm, set_term and delscreen are not yet implemented+-- FIXME: initscr and newterm may be macros++{#fun unsafe initscr {} -> `Window' id#}+{#fun unsafe endwin {} -> `Status' toStatus*#}+{#fun unsafe isendwin {} -> `Bool'#}++------------------------------------------------------------------------+-- addstr(3NCURSES)+------------------------------------------------------------------------++-- FIXME: all of these routines except waddstr and waddnstr may be macros++{#fun unsafe addstr {`String'} -> `Status' toStatus*#}+{#fun unsafe addnstr {`String', `Int'} -> `Status' toStatus*#}+{#fun unsafe waddstr {id `Window', `String'} -> `Status' toStatus*#}+{#fun unsafe waddnstr {id `Window', `String', `Int'} -> `Status' toStatus*#}+{#fun unsafe mvaddstr {`Int', `Int', `String'} -> `Status' toStatus*#}+{#fun unsafe mvaddnstr {`Int', `Int', `String', `Int'} -> `Status' toStatus*#}+{#fun unsafe mvwaddstr {id `Window', `Int', `Int', `String'} -> `Status' toStatus*#}+{#fun unsafe mvwaddnstr {id `Window', `Int', `Int', `String', `Int'} -> `Status' toStatus*#}++------------------------------------------------------------------------+-- addwstr(3NCURSES)+------------------------------------------------------------------------+-- int addwstr(const wchar_t *wstr);+-- int addnwstr(const wchar_t *wstr, int n);+-- int waddwstr(WINDOW *win, const wchar_t *wstr);+-- int waddnwstr(WINDOW *win, const wchar_t *wstr, int n);+-- int mvaddwstr(int y, int x, const wchar_t *wstr);+-- int mvaddnwstr(int y, int x, const wchar_t *wstr, int n);+-- int mvwaddwstr(WINDOW *win, int y, int x, const wchar_t *wstr);+-- int mvwaddnwstr(WINDOW *win, int y, int x, const wchar_t *wstr, int n);+{#fun unsafe mvwaddnwstr as mvwaddnwstr_ {id `Window', `Int', `Int', castPtr `CWString', `Int'} -> `Status' toStatus*#}++mvwaddnwstr :: Window -> Int -> Int -> String -> Int -> IO Status+mvwaddnwstr win y x str n = newCWString str >>= \s -> mvwaddnwstr_ win y x s n++------------------------------------------------------------------------+-- refresh(3NCURSES)+------------------------------------------------------------------------++-- FIXME: refresh and redrawwin may be macros++{#fun unsafe refresh {} -> `Status' toStatus*#}+{#fun unsafe wrefresh {id `Window'} -> `Status' toStatus*#}+{#fun unsafe wnoutrefresh {id `Window'} -> `Status' toStatus*#}+{#fun unsafe doupdate {} -> `Status' toStatus*#}+{#fun unsafe redrawwin {id `Window'} -> `Status' toStatus*#}+{#fun unsafe wredrawln {id `Window', `Int', `Int'} -> `Status' toStatus*#}++------------------------------------------------------------------------+-- getyx(3NCURSES)+------------------------------------------------------------------------++{#fun unsafe nm_getyx as getyx {id `Window', alloca- `Int' peekInt*, alloca- `Int' peekInt*} -> `()'#}+{#fun unsafe nm_getparyx as getparyx {id `Window', alloca- `Int' peekInt*, alloca- `Int' peekInt*} -> `()'#}+{#fun unsafe nm_getbegyx as getbegyx {id `Window', alloca- `Int' peekInt*, alloca- `Int' peekInt*} -> `()'#}+{#fun unsafe nm_getmaxyx as getmaxyx {id `Window', alloca- `Int' peekInt*, alloca- `Int' peekInt*} -> `()'#}++peekInt :: Ptr CInt -> IO Int+peekInt = fmap fromIntegral . peek++#c+void nm_getyx(WINDOW* win, int* y, int* x);+void nm_getparyx(WINDOW *win, int* y, int* x);+void nm_getbegyx(WINDOW *win, int* y, int* x);+void nm_getmaxyx(WINDOW* win, int* y, int* x);+#endc++------------------------------------------------------------------------+-- TODO+------------------------------------------------------------------------++-- curscr+-- wtouchln+-- set_escdelay+++------------------------------------------------------------------------+-- addch(3NCURSES)+------------------------------------------------------------------------+-- int addch(const chtype ch);+-- int waddch(WINDOW *win, const chtype ch);+{#fun unsafe waddch {id `Window', fromChar' `Char'} -> `Status' toStatus*#}++fromChar' :: Char -> Chtype_t+fromChar' = fromIntegral . ord++-- int mvaddch(int y, int x, const chtype ch);+-- int mvwaddch(WINDOW *win, int y, int x, const chtype ch);+{#fun unsafe mvwaddch {id `Window', `Int', `Int', fromChar' `Char'} -> `Status' toStatus*#}++-- int echochar(const chtype ch);+-- int wechochar(WINDOW *win, const chtype ch);++++#c+WINDOW* get_stdscr(void);+#endc+stdscr :: Window+stdscr = {#call pure get_stdscr#}++++cFromBool = fromBool+++------------------------------------------------------------------------+-- inopts(3NCURSES)+------------------------------------------------------------------------++-- int cbreak(void);+{#fun unsafe cbreak {} -> `Status' toStatus*#}++-- int nocbreak(void);+{#fun unsafe nocbreak {} -> `Status' toStatus*#}++-- int echo(void);+{#fun unsafe echo {} -> `Status' toStatus*#}++-- int noecho(void);+{#fun unsafe noecho {} -> `Status' toStatus*#}++-- int halfdelay(int tenths);+{#fun unsafe halfdelay {`Int'} -> `Status' toStatus*#}++-- int intrflush(WINDOW *win, bool bf);+{#fun unsafe intrflush {id `Window', `Bool'} -> `Status' toStatus*#}++-- int keypad(WINDOW *win, bool bf);+{#fun unsafe keypad {id `Window', `Bool'} -> `Status' toStatus*#}++-- int meta(WINDOW *win, bool bf);+{#fun unsafe meta {id `Window', `Bool'} -> `Status' toStatus*#}++-- int nodelay(WINDOW *win, bool bf);+{#fun unsafe nodelay {id `Window', `Bool'} -> `Status' toStatus*#}++-- int raw(void);+{#fun unsafe raw {} -> `Status' toStatus*#}++-- int noraw(void);+{#fun unsafe noraw {} -> `Status' toStatus*#}++-- void noqiflush(void);+{#fun unsafe noqiflush {} -> `()'#}++-- void qiflush(void);+{#fun unsafe qiflush {} -> `()'#}++-- int notimeout(WINDOW *win, bool bf);+{#fun unsafe notimeout {id `Window', `Bool'} -> `Status' toStatus*#}++-- void timeout(int delay);+{#fun unsafe timeout {`Int'} -> `()'#}++-- void wtimeout(WINDOW *win, int delay);+{#fun unsafe wtimeout {id `Window', `Int'} -> `()'#}++-- int typeahead(int fd);+--{#fun unsafe typeahead {`Int'} -> `()'#}+++------------------------------------------------------------------------+-- outopts(3NCURSES)+------------------------------------------------------------------------++{#fun unsafe nl {} -> `Status' toStatus*#}+{#fun unsafe nonl {} -> `Status' toStatus*#}+{#fun unsafe wdelch {id `Window'} -> `Status' toStatus*#}++{#fun unsafe move {`Int', `Int'} -> `Status' toStatus*#}++{#fun unsafe werase {id `Window'} -> `Status' toStatus*#}+{#fun unsafe wclrtoeol {id `Window'} -> `Status' toStatus*#}+{#fun unsafe clrtoeol {} -> `Status' toStatus*#}+++-- |+-- Set the cursor state to invisible, normal, or very visible for visibility+-- equal to 0, 1, or 2 respectively. Return the previous cursor state, if the+-- terminal supports the visibility requested; ERR otherwise.+--+-- TODO: handle ERR properly, use symbolic argument for visibility+{#fun unsafe curs_set {`Int'} -> `Int' fromIntegral#}+++------------------------------------------------------------------------+-- window(3NCURSES)+------------------------------------------------------------------------++-- WINDOW *newwin(int nlines, int ncols, int begin_y, int begin_x);++{#fun unsafe newwin {`Int', `Int', `Int', `Int'} -> `Window' id#}++-- int delwin(WINDOW *win);+{#fun unsafe delwin {id `Window'} -> `Status' toStatus*#}++-- int mvwin(WINDOW *win, int y, int x);+{#fun unsafe mvwin {id `Window', `Int', `Int'} -> `Status' toStatus*#}++++------------------------------------------------------------------------+-- pad(3NCURSES)+------------------------------------------------------------------------++-- WINDOW *newpad(int nlines, int ncols);+{#fun unsafe newpad {`Int', `Int'} -> `Window' id#}++-- WINDOW *subpad(WINDOW *orig, int nlines, int ncols, int begin_y, int begin_x);++-- int prefresh(WINDOW *pad, int pminrow, int pmincol, int sminrow, int smincol, int smaxrow, int smaxcol);+{#fun unsafe prefresh {id `Window', `Int', `Int', `Int', `Int', `Int', `Int'} -> `Status' toStatus*#}++-- int pnoutrefresh(WINDOW *pad, int pminrow, int pmincol, int sminrow, int smincol, int smaxrow, int smaxcol);++-- int pechochar(WINDOW *pad, chtype ch);++-- int pecho_wchar(WINDOW *pad, const cchar_t *wch);++{-+#c+void mytrace(void);+#endc++{#fun unsafe mytrace {} -> `()'#}+-}
+ ncursesw/src/CursesInput.chs view
@@ -0,0 +1,76 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module CursesInput where++import Foreign.C.Types+import Data.Char (chr, ord)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Storable (peek)+import Foreign.Ptr (Ptr)++import CursesUtil+import qualified Constant+{# import UI.Curses.Type #}++#include "mycurses.h"++------------------------------------------------------------------------+-- getch(3NCURSES)+------------------------------------------------------------------------++-- TODO read manpage++-- int getch(void);+{#fun getch {} -> `Char' decodeKey#}++-- int wgetch(WINDOW *win);+{#fun wgetch {id `Window'} -> `Char' decodeKey#}+++-- int mvgetch(int y, int x);+-- {#fun unsafe mvgetch {`Int', `Int'} -> `Char' decodeKey#}++-- int mvwgetch(WINDOW *win, int y, int x);+-- {#fun unsafe mvwgetch {id `Window', `Int', `Int'} -> `Char' decodeKey#}++-- int ungetch(int ch);+{#fun unsafe ungetch {fromChar `Char'} -> `Status' toStatus*#}++-- int has_key(int ch);+-- {#fun unsafe has_key {fromChar `Char'} -> `Bool'#}+++++-- getch returns ERR on various occasions, which is defined to -1. As -1 has+-- no corresponding Char value, we map it to '\xffff'. Unicode guarantees,+-- that '\xffff' is not a character at all.+not_a_character :: Char+not_a_character = '\xffff'++decodeKey :: CInt -> Char+decodeKey c = if c == Constant.err+ then not_a_character+ else chr $ fromIntegral c++fromChar :: Char -> CInt+fromChar = fromIntegral . ord++{#fun pure keyF {fromIntegral `Int'} -> `Char' decodeKey#}++#c+int keyF(int n);+#endc++-- wide character support++-- FIXME: right now the return type is IO (Status, Char), can we change that to+-- plain Char somehow?+{#fun get_wch {alloca- `Char' peekChar*} -> `Status' toStatus*#}++{#fun wget_wch as wget_wch_ {id `Window', alloca- `Char' peekChar*} -> `Status' toStatus*#}++wget_wch :: Window -> IO Char+wget_wch window = fmap snd $ wget_wch_ window++peekChar :: Ptr Wint_t -> IO Char+peekChar = fmap (chr . fromIntegral) . peek
+ ncursesw/src/CursesUtil.hs view
@@ -0,0 +1,21 @@+module CursesUtil (Status, toStatus, err, ok, cIntConv) where++import Foreign.C.Types++import qualified Constant++cIntConv :: Int -> CInt+cIntConv = fromIntegral++------------------------------------------------------------------------+-- error handling+------------------------------------------------------------------------+newtype Status = Status CInt++err, ok :: Status+err = Status Constant.err+ok = Status Constant.ok++toStatus :: CInt -> IO Status+toStatus = return . Status+-- toStatus n = if n == Constant.err then error "curses function returned ERR" else return $ Status n
+ ncursesw/src/Misc.chs view
@@ -0,0 +1,182 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module Misc where++import Foreign.C.Types+import Foreign.Ptr+import Foreign.C.String+import Foreign.Marshal.Alloc+import Foreign.Storable+import Foreign.ForeignPtr++import Data.Char+import Data.List (foldl')+import Foreign.Marshal.Utils (fromBool, toBool)++import Data.Bits++import qualified Constant+import CursesUtil++{# import UI.Curses.Type #}++-- import Foreign.Storable++#include "mycurses.h"++++cFromBool = fromBool+cToBool = toBool++------------------------------------------------------------------------+-- attr+------------------------------------------------------------------------++-- | Deprecated, use Attribute instead+newtype Attr = Attr CInt++(&) :: Attr -> Attr -> Attr+(Attr a) & (Attr b) = Attr (a .|. b)++fromAttr (Attr a) = a++-- {#fun unsafe attron {fromAttr `Attr'} -> `Status' toStatus*#}+-- {#fun unsafe attroff {fromAttr `Attr'} -> `Status' toStatus*#}+++{#enum define Attribute {+ WA_NORMAL as Normal+, WA_STANDOUT as Standout+, WA_UNDERLINE as Underline+, WA_REVERSE as Reverse+, WA_BLINK as Blink+, WA_DIM as Dim+, WA_BOLD as Bold+, WA_ALTCHARSET as Altcharset+, WA_INVIS as Invis+, WA_PROTECT as Protect+}#}+-- not yet implemented by ncurses, so we do not define them+{-+, WA_HORIZONTAL as Horizontal+, WA_LEFT as Left+, WA_LOW as Low+, WA_RIGHT as Right+, WA_TOP as Top+, WA_VERTICAL as Vertical+-}+++combine :: [Attribute] -> Attr_t+combine l = foldl' (.|.) 0 $ map (fromIntegral . fromEnum) l++-- int wcolor_set(WINDOW *win, short color_pair_number, void* opts);+{#fun unsafe wcolor_set as wcolor_set_ {id `Window', shortFromInt `Int', id `Ptr ()'} -> `Status' toStatus*#}++wcolor_set window color = wcolor_set_ window color nullPtr++-- int wstandend(WINDOW *win);+-- int wstandout(WINDOW *win);+--+-- int wattr_get(WINDOW *win, attr_t *attrs, short *pair, void *opts);++-- int wattr_off(WINDOW *win, attr_t attrs, void *opts);+{#fun unsafe wattr_off as wattr_off_ {id `Window', combine `[Attribute]', id `Ptr ()'} -> `Status' toStatus*#}+wattr_off win attrs = wattr_off_ win attrs nullPtr++-- int wattr_on(WINDOW *win, attr_t attrs, void *opts);+{#fun unsafe wattr_on as wattr_on_ {id `Window', combine `[Attribute]', id `Ptr ()'} -> `Status' toStatus*#}+wattr_on win attrs = wattr_on_ win attrs nullPtr++-- int wattr_set(WINDOW *win, attr_t attrs, short pair, void *opts);+--+++-- int wchgat(WINDOW *win, int n, attr_t attr, short color, const void *opts)+{#fun unsafe wchgat as wchgat_ {id `Window', `Int', combine `[Attribute]', shortFromInt `Int', id `Ptr ()'} -> `Status' toStatus*#}+wchgat win n attrs color = wchgat_ win n attrs color nullPtr++-- int mvwchgat(WINDOW *win, int y, int x, int n, attr_t attr, short color, const void *opts)+{#fun unsafe mvwchgat as mvwchgat_ {id `Window', `Int', `Int', `Int', combine `[Attribute]', shortFromInt `Int', id `Ptr ()'} -> `Status' toStatus*#}++mvwchgat win y x n attrs color = mvwchgat_ win y x n attrs color nullPtr+++------------------------------------------------------------------------+-- color(3NCURSES)+------------------------------------------------------------------------+newtype Color = Color CShort+ deriving (Eq, Show)++fromColor :: Color -> CShort+fromColor (Color a) = a++black, red, green, yellow, blue, magenta, cyan, white :: Color+black = Color Constant.black+red = Color Constant.red+green = Color Constant.green+yellow = Color Constant.yellow+blue = Color Constant.blue+magenta = Color Constant.magenta+cyan = Color Constant.cyan+white = Color Constant.white+++-- int start_color(void);+{#fun unsafe start_color {} -> `Status' toStatus*#}++-- int init_pair(short pair, short f, short b);+{#fun unsafe init_pair {shortFromInt `Int', fromColor `Color', fromColor `Color'} -> `Status' toStatus*#}++-- int init_color(short color, short r, short g, short b);+{#fun unsafe init_color {fromColor `Color', shortFromInt `Int', shortFromInt `Int', shortFromInt `Int'} -> `Status' toStatus*#}++-- bool has_colors(void);+{#fun pure has_colors {} -> `Bool'#}++-- bool can_change_color(void);+{#fun unsafe can_change_color {} -> `Bool'#}++-- int color_content(short color, short *r, short *g, short *b);+-- int pair_content(short pair, short *f, short *b);+++shortFromInt :: Int -> CShort+shortFromInt = fromIntegral+++#c+int color_pair(short n);+#endc+{#fun pure color_pair {shortFromInt `Int'} -> `Attr' Attr#}++------------------------------------------------------------------------+-- default_colors(3NCURSES)+------------------------------------------------------------------------++-- int use_default_colors(void);+{#fun unsafe use_default_colors {} -> `Status' toStatus*#}++-- int assume_default_colors(int fg, int bg);+{#fun unsafe assume_default_colors {fromColor' `Color', fromColor' `Color'} -> `Status' toStatus*#}++fromColor' :: Color -> CInt+fromColor' = fromIntegral . fromColor++------------------------------------------------------------------------+-- bkgd(3NCURSES)+------------------------------------------------------------------------++-- TODO: support setting of background character, not only attribute++{#fun unsafe bkgdset {chtypeFromAttr `Attr'} -> `()'#}+{#fun unsafe wbkgdset {id `Window', chtypeFromAttr `Attr'} -> `()'#}+{#fun unsafe bkgd {chtypeFromAttr `Attr'} -> `Status' toStatus*#}+{#fun unsafe wbkgd {id `Window', chtypeFromAttr `Attr'} -> `Status' toStatus*#}++-- TODO+-- chtype getbkgd(WINDOW *win);++chtypeFromAttr :: Attr -> Chtype_t+chtypeFromAttr = fromIntegral . fromAttr
+ ncursesw/src/UI/Curses.hs view
@@ -0,0 +1,3 @@+module UI.Curses (module Curses) where++import Curses
+ ncursesw/src/UI/Curses/Key.hsc view
@@ -0,0 +1,367 @@+module UI.Curses.Key where++import Data.Char (chr)++#include "mycurses.h"++------------------------------------------------------------------------+-- getch(3NCURSES)+------------------------------------------------------------------------++-- TODO KEY_F+++-- | Break key+keyBreak :: Char+keyBreak = chr (#const KEY_BREAK)++-- | The four arrow keys ...+keyDown :: Char+keyDown = chr (#const KEY_DOWN)++keyUp :: Char+keyUp = chr (#const KEY_UP)++keyLeft :: Char+keyLeft = chr (#const KEY_LEFT)++keyRight :: Char+keyRight = chr (#const KEY_RIGHT)++-- | Home key (upward+left arrow)+keyHome :: Char+keyHome = chr (#const KEY_HOME)++-- | Backspace+keyBackspace :: Char+keyBackspace = chr (#const KEY_BACKSPACE)++-- | Delete line+keyDl :: Char+keyDl = chr (#const KEY_DL)++-- | Insert line+keyIl :: Char+keyIl = chr (#const KEY_IL)++-- | Delete character+keyDc :: Char+keyDc = chr (#const KEY_DC)++-- | Insert char or enter insert mode+keyIc :: Char+keyIc = chr (#const KEY_IC)++-- | Exit insert char mode+keyEic :: Char+keyEic = chr (#const KEY_EIC)++-- | Clear screen+keyClear :: Char+keyClear = chr (#const KEY_CLEAR)++-- | Clear to end of screen+keyEos :: Char+keyEos = chr (#const KEY_EOS)++-- | Clear to end of line+keyEol :: Char+keyEol = chr (#const KEY_EOL)++-- | Scroll 1 line forward+keySf :: Char+keySf = chr (#const KEY_SF)++-- | Scroll 1 line backward (reverse)+keySr :: Char+keySr = chr (#const KEY_SR)++-- | Next page+keyNpage :: Char+keyNpage = chr (#const KEY_NPAGE)++-- | Previous page+keyPpage :: Char+keyPpage = chr (#const KEY_PPAGE)+++-- | Clear tab+keyCtab :: Char+keyCtab = chr (#const KEY_CTAB)++-- | Clear all tabs+keyCatab :: Char+keyCatab = chr (#const KEY_CATAB)++-- | Enter or send+keyEnter :: Char+keyEnter = chr (#const KEY_ENTER)++-- | Soft (partial) reset+keySreset :: Char+keySreset = chr (#const KEY_SRESET)++-- | Reset or hard reset+keyReset :: Char+keyReset = chr (#const KEY_RESET)++-- | Print or copy+keyPrint :: Char+keyPrint = chr (#const KEY_PRINT)++-- | Home down or bottom (lower left)+keyLl :: Char+keyLl = chr (#const KEY_LL)++-- | Upper left of keypad+keyA1 :: Char+keyA1 = chr (#const KEY_A1)++-- | Upper right of keypad+keyA3 :: Char+keyA3 = chr (#const KEY_A3)++-- | Center of keypad+keyB2 :: Char+keyB2 = chr (#const KEY_B2)++-- | Lower left of keypad+keyC1 :: Char+keyC1 = chr (#const KEY_C1)++-- | Lower right of keypad+keyC3 :: Char+keyC3 = chr (#const KEY_C3)++-- | Back tab key+keyBtab :: Char+keyBtab = chr (#const KEY_BTAB)++-- | Beg(inning) key+keyBeg :: Char+keyBeg = chr (#const KEY_BEG)++-- | Cancel key+keyCancel :: Char+keyCancel = chr (#const KEY_CANCEL)++-- | Close key+keyClose :: Char+keyClose = chr (#const KEY_CLOSE)++-- | Cmd (command) key+keyCommand :: Char+keyCommand = chr (#const KEY_COMMAND)++-- | Copy key+keyCopy :: Char+keyCopy = chr (#const KEY_COPY)++-- | Create key+keyCreate :: Char+keyCreate = chr (#const KEY_CREATE)++-- | End key+keyEnd :: Char+keyEnd = chr (#const KEY_END)++-- | Exit key+keyExit :: Char+keyExit = chr (#const KEY_EXIT)++-- | Find key+keyFind :: Char+keyFind = chr (#const KEY_FIND)++-- | Help key+keyHelp :: Char+keyHelp = chr (#const KEY_HELP)++-- | Mark key+keyMark :: Char+keyMark = chr (#const KEY_MARK)++-- | Message key+keyMessage :: Char+keyMessage = chr (#const KEY_MESSAGE)++-- | Mouse event read+keyMouse :: Char+keyMouse = chr (#const KEY_MOUSE)++-- | Move key+keyMove :: Char+keyMove = chr (#const KEY_MOVE)++-- | Next object key+keyNext :: Char+keyNext = chr (#const KEY_NEXT)++-- | Open key+keyOpen :: Char+keyOpen = chr (#const KEY_OPEN)++-- | Options key+keyOptions :: Char+keyOptions = chr (#const KEY_OPTIONS)++-- | Previous object key+keyPrevious :: Char+keyPrevious = chr (#const KEY_PREVIOUS)++-- | Redo key+keyRedo :: Char+keyRedo = chr (#const KEY_REDO)++-- | Ref(erence) key+keyReference :: Char+keyReference = chr (#const KEY_REFERENCE)++-- | Refresh key+keyRefresh :: Char+keyRefresh = chr (#const KEY_REFRESH)++-- | Replace key+keyReplace :: Char+keyReplace = chr (#const KEY_REPLACE)++-- | Screen resized+keyResize :: Char+keyResize = chr (#const KEY_RESIZE)++-- | Restart key+keyRestart :: Char+keyRestart = chr (#const KEY_RESTART)++-- | Resume key+keyResume :: Char+keyResume = chr (#const KEY_RESUME)++-- | Save key+keySave :: Char+keySave = chr (#const KEY_SAVE)++-- | Shifted beginning key+keySbeg :: Char+keySbeg = chr (#const KEY_SBEG)++-- | Shifted cancel key+keyScancel :: Char+keyScancel = chr (#const KEY_SCANCEL)++-- | Shifted command key+keyScommand :: Char+keyScommand = chr (#const KEY_SCOMMAND)++-- | Shifted copy key+keyScopy :: Char+keyScopy = chr (#const KEY_SCOPY)++-- | Shifted create key+keyScreate :: Char+keyScreate = chr (#const KEY_SCREATE)++-- | Shifted delete char key+keySdc :: Char+keySdc = chr (#const KEY_SDC)++-- | Shifted delete line key+keySdl :: Char+keySdl = chr (#const KEY_SDL)++-- | Select key+keySelect :: Char+keySelect = chr (#const KEY_SELECT)++-- | Shifted end key+keySend :: Char+keySend = chr (#const KEY_SEND)++-- | Shifted clear line key+keySeol :: Char+keySeol = chr (#const KEY_SEOL)++-- | Shifted exit key+keySexit :: Char+keySexit = chr (#const KEY_SEXIT)++-- | Shifted find key+keySfind :: Char+keySfind = chr (#const KEY_SFIND)++-- | Shifted help key+keyShelp :: Char+keyShelp = chr (#const KEY_SHELP)++-- | Shifted home key+keyShome :: Char+keyShome = chr (#const KEY_SHOME)++-- | Shifted input key+keySic :: Char+keySic = chr (#const KEY_SIC)++-- | Shifted left arrow key+keySleft :: Char+keySleft = chr (#const KEY_SLEFT)++-- | Shifted message key+keySmessage :: Char+keySmessage = chr (#const KEY_SMESSAGE)++-- | Shifted move key+keySmove :: Char+keySmove = chr (#const KEY_SMOVE)++-- | Shifted next key+keySnext :: Char+keySnext = chr (#const KEY_SNEXT)++-- | Shifted options key+keySoptions :: Char+keySoptions = chr (#const KEY_SOPTIONS)++-- | Shifted prev key+keySprevious :: Char+keySprevious = chr (#const KEY_SPREVIOUS)++-- | Shifted print key+keySprint :: Char+keySprint = chr (#const KEY_SPRINT)++-- | Shifted redo key+keySredo :: Char+keySredo = chr (#const KEY_SREDO)++-- | Shifted replace key+keySreplace :: Char+keySreplace = chr (#const KEY_SREPLACE)++-- | Shifted right arrow+keySright :: Char+keySright = chr (#const KEY_SRIGHT)++-- | Shifted resume key+keySrsume :: Char+keySrsume = chr (#const KEY_SRSUME)+++-- | Shifted save key+keySsave :: Char+keySsave = chr (#const KEY_SSAVE)++-- | Shifted suspend key+keySsuspend :: Char+keySsuspend = chr (#const KEY_SSUSPEND)++-- | Shifted undo key+keySundo :: Char+keySundo = chr (#const KEY_SUNDO)++-- | Suspend key+keySuspend :: Char+keySuspend = chr (#const KEY_SUSPEND)++-- | Undo key+keyUndo :: Char+keyUndo = chr (#const KEY_UNDO)
+ ncursesw/src/UI/Curses/Type.chs view
@@ -0,0 +1,18 @@+module UI.Curses.Type where++import Foreign.C.Types+import Foreign.Ptr (Ptr)++#include "mycurses.h"++{#pointer *WINDOW as Window newtype#}++{-+Wrapper types corresponding to typedefs on the C side,+to avoid making assumptions about what their underlying+types are (e.g., the underlying type of chtype is+user-configurable).+-}+type Attr_t = {#type attr_t #}+type Chtype_t = {#type chtype #}+type Wint_t = {#type wint_t #}
+ ncursesw/src/cbits.c view
@@ -0,0 +1,42 @@+#include "mycurses.h"+++WINDOW* get_stdscr(void) {+ return stdscr;+}++int keyF(int n) {+ return KEY_F(n);+}++/* attr */+int color_pair(short n) {+ return COLOR_PAIR(n);+}++/***********************************************************************+ * getyx(3NCURSES)+ ***********************************************************************/+void nm_getyx(WINDOW* win, int* y, int* x) {+ getyx(win, *y, *x);+}++void nm_getparyx(WINDOW *win, int* y, int* x) {+ getparyx(win, *y, *x);+}++void nm_getbegyx(WINDOW *win, int* y, int* x) {+ getbegyx(win, *y, *x);+}++void nm_getmaxyx(WINDOW* win, int* y, int* x) {+ getmaxyx(win, *y, *x);+}+++// FIXME: add proper binding to trace functions+/*+void mytrace(void) {+ trace(TRACE_VIRTPUT);+}+*/
+ ncursesw/src/mycurses.h view
@@ -0,0 +1,10 @@+/* Customize the system-wide curses header. */++/* be C89 compliant */+#define NCURSES_ENABLE_STDBOOL_H 0++#define _XOPEN_SOURCE_EXTENDED+#define NCURSES_NOMACROS+#define NCURSES_OPAQUE 1++#include <curses.h>
+ resource/default-mappings view
@@ -0,0 +1,65 @@+# default mappings+#+# A mapping maps a shortcut to one or more commands. Whenever the user enters+# a shortcut, the corresponding commands are executed.++# quit+map <C-C> :quit<CR>++# settings+map r :toggle-repeat<CR>+map R :toggle-random<CR>+map c :toggle-consume<CR>+map s :toggle-single<CR>++# movement+map k :move-up<CR>+map <Up> :move-up<CR>+map j :move-down<CR>+map <Down> :move-down<CR>+map { :move-album-prev<CR>+map } :move-album-next<CR>+map h :move-out<CR>+map l :move-in<CR>+map gg :move-first<CR>+map G :move-last<CR>+map <C-Y> :scroll-up<CR>+map <C-E> :scroll-down<CR>+map <C-U> :scroll-half-page-up<CR>+map <C-B> :scroll-page-up<CR>+map <PageUp> :scroll-page-up<CR>+map <C-D> :scroll-half-page-down<CR>+map <C-F> :scroll-page-down<CR>+map <PageDown> :scroll-page-down<CR>++# tab navigation+map q :close<CR>+map <C-P> :window-prev<CR>+map <C-N> :window-next<CR>+map 1 :window-playlist<CR>+map 2 :window-library<CR>+map 3 :window-browser<CR>+map 4 :window-search<CR>++# playback+map <CR> :default-action<CR>+map t :toggle<CR>+map d :remove<CR>+map y :copy<CR>+map p :paste<CR>+map P :paste-prev<CR>+map a :add<CR>+map i :insert<CR>+map A :add-album<CR>+map <Left> :seek -5<CR>+map <Right> :seek 5<CR>+map + :volume +5<CR>+map - :volume -5<CR>++# search+map n :search-next<CR>+map N :search-prev<CR>++# selecting+map v :visual<CR>+map <ESC> :novisual<CR>
+ resource/emacs-mappings view
@@ -0,0 +1,25 @@+# quit+unmap <c-c>+map <c-x><c-c> :quit<cr>++# movement+map <c-p> :move-up<cr>+map <c-n> :move-down<cr>+map <c-x>] :move-last<cr>+map <c-x>[ :move-first<cr>+map <c-v> :scroll-up<cr>+map <esc>v :scroll-down<cr>++# windows+map <c-x>b :window-next<cr>+map <c-x>0 :close<cr>++# help+map <c-h>i :help<cr>+map <c-h>k :map<cr>++# alt-x execute-command+map <esc>x :++# search+map <c-s> /
+ src/Command.hs view
@@ -0,0 +1,899 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes, TupleSections, RecordWildCards #-}+module Command (+ runCommand+, autoComplete+, source+, tabs++-- * exported for testing+, MacroName (..)+, MacroExpansion (..)+, ShellCommand (..)+, Volume(..)+) where++import Data.Function+import Data.List+import Data.Char+import Data.Maybe (mapMaybe, fromMaybe, listToMaybe)+import Data.Ord (comparing)+import Control.Monad (void, when, unless, guard)+import Control.Applicative+import Data.Foldable (foldMap, forM_, for_)+import Data.Traversable (for)+import Text.Printf (printf)+import Text.Read (readMaybe)+import System.Exit+import System.Process (system)++import System.Directory (doesFileExist)+import System.FilePath ((</>), dropFileName)+import Data.Map (Map, (!))+import qualified Data.Map as Map++import Data.Time.Clock.POSIX++import Control.Monad.State.Strict (gets, liftIO)+import Control.Monad.Error (catchError)++import Network.MPD ((=?))+import qualified Network.MPD as MPD hiding (withMPD)+import qualified Network.MPD.Commands.Extensions as MPDE+import qualified Network.MPD.Applicative as MPDA++import UI.Curses hiding (wgetch, ungetch, mvaddstr, err)++import Paths_vimus (getDataFileName)++import Util+import Vimus+import Widget.ListWidget (ListWidget)+import qualified Widget.ListWidget as ListWidget+import Widget.HelpWidget+import Content+import WindowLayout+import Key (ExpandKeyError (..), keyNames, expandKeys)+import qualified Macro+import Input (CompletionFunction)+import Command.Core+import Command.Help (help)+import Command.Parser+import Command.Completion++import Tab (Tabs)+import qualified Tab+import Song.Format (SongFormat)+import Widget.Type (Renderable, renderItem, toPlainText)++{-# ANN module ("HLint: ignore Redundant do" :: String) #-}++-- | Initial tabs after startup.+tabs :: Tabs AnyWidget+tabs = Tab.fromList [+ tab Playlist (PlaylistWidget (const False) 0)+ , tab Library LibraryWidget+ , tab Browser BrowserWidget+ ]+ where+ tab :: Widget w => TabName -> (ListWidget SongFormat a -> w) -> Tab AnyWidget+ tab n t = Tab n (AnyWidget . t $ ListWidget.new []) Persistent++data PlaylistWidget = PlaylistWidget {+ plMarked :: MPD.Song -> Bool+, plLastAction :: POSIXTime+, plSongs :: ListWidget SongFormat MPD.Song+}++instance Widget PlaylistWidget where+ render PlaylistWidget{..} = ListWidget.render plMarked plSongs+ currentItem PlaylistWidget{..} = Song <$> ListWidget.select plSongs+ searchItem pl@PlaylistWidget{..} o s = pl{plSongs = searchItem plSongs o s}+ filterItem pl@PlaylistWidget{..} s = pl{plSongs = filterItem plSongs s}+ handleEvent PlaylistWidget{plSongs = l, ..} ev =+ PlaylistWidget isMarked <$> time <*> case ev of+ EvPlaylistChanged -> MPDA.runCommand updatePlaylist++ EvCurrentSongChanged mSong -> do++ -- set window title+ b <- getAutoTitle+ when b $ do+ let format = ListWidget.getElementsFormat l+ title = case mSong of+ Nothing -> "vimus"+ Just s -> "vimus: " ++ toPlainText (renderItem format s)+ liftIO (endwin >> setTitle title)++ t <- currentTime+ let mIndex = mSong >>= MPD.sgIndex+ dt = t - plLastAction+ return $ if 10 < dt+ then maybe l (ListWidget.setPosition l) mIndex+ else l++ EvDefaultAction -> do+ -- play selected song+ forM_ (ListWidget.select l >>= MPD.sgId) MPD.playId+ return l++ EvRemove -> do+ eval "copy"+ MPDA.runCommand $ do+ for_ (mapMaybe MPD.sgId $ ListWidget.selected l) MPDA.deleteId++ -- It is important to call `removeSelected` here, and not rely on+ -- EvPlaylistChanged, so that subsequent commands work on a current+ -- playlist!+ return (ListWidget.removeSelected l)++ EvPaste -> do+ paste $ min (succ $ ListWidget.getPosition l) (ListWidget.getLength l)++ EvPastePrevious -> do+ paste (ListWidget.getPosition l)++ EvAdd -> runSongListAction addAction+ EvInsert pos -> runSongListAction (insertAction pos)++ EvChangeSongFormat format ->+ return (ListWidget.setElementsFormat format l)++ _ -> songListHandler l ev+ where+ runSongListAction action =+ MPDA.runCommand (mpdCommand *> updatePlaylist) >>= vimusAction+ where+ (mpdCommand, vimusAction) = action l++ paste :: Int -> Vimus SongList+ paste n = do+ songs <- readCopyRegister+ case length songs of+ 0 -> return l+ _ -> MPDA.runCommand $+ for_ (zip songs $ map Just [n..]) (uncurry MPDA.addId) *>+ -- It is important to call `updatePlaylist` here to prevent raise+ -- conditions between EvPlaylistChanged and subsequent commands!+ (flip ListWidget.setPosition n <$> updatePlaylist)++ -- compare songs by playlist id+ eq = (==) `on` MPD.sgId++ updatePlaylist = do+ ListWidget.update eq l <$> MPDA.playlistInfo Nothing++ isMarked = case ev of+ EvCurrentSongChanged mSong -> maybe (const False) eq mSong+ _ -> plMarked++ currentTime = liftIO getPOSIXTime+ keep = return plLastAction+ time = case ev of+ EvCurrentSongChanged {} -> keep+ EvPlaylistChanged {} -> keep+ EvLibraryChanged {} -> keep+ EvResize {} -> keep+ EvLogMessage {} -> keep+ EvDefaultAction {} -> currentTime+ EvMoveUp {} -> currentTime+ EvMoveDown {} -> currentTime+ EvMoveAlbumPrev {} -> currentTime+ EvMoveAlbumNext {} -> currentTime+ EvMoveIn {} -> currentTime+ EvMoveOut {} -> currentTime+ EvMoveFirst {} -> currentTime+ EvMoveLast {} -> currentTime+ EvScroll {} -> currentTime+ EvVisual {} -> currentTime+ EvNoVisual {} -> currentTime+ EvAdd {} -> currentTime+ EvInsert {} -> currentTime+ EvRemove {} -> currentTime+ EvCopy {} -> currentTime+ EvPaste {} -> currentTime+ EvPastePrevious {} -> currentTime+ EvChangeSongFormat {} -> currentTime++newtype LibraryWidget = LibraryWidget (ListWidget SongFormat MPD.Song)++instance Widget LibraryWidget where+ render (LibraryWidget w) = render w+ currentItem (LibraryWidget w) = Song <$> ListWidget.select w+ searchItem (LibraryWidget w) o t = LibraryWidget (searchItem w o t)+ filterItem (LibraryWidget w) t = LibraryWidget (filterItem w t)+ handleEvent (LibraryWidget l) ev = LibraryWidget <$> case ev of+ EvLibraryChanged songs -> do+ let eq = (==) `on` MPD.sgFilePath+ return $ ListWidget.update eq l (foldr consSong [] songs)++ EvDefaultAction -> do+ -- add selected song to playlist, and play it+ forM_ (ListWidget.select l) $ \song ->+ MPD.addId (MPD.sgFilePath song) Nothing >>= MPD.playId+ return l++ EvAdd -> runSongListAction addAction+ EvInsert pos -> runSongListAction (insertAction pos)++ EvChangeSongFormat format ->+ return (ListWidget.setElementsFormat format l)++ _ -> songListHandler l ev+ where+ runSongListAction action =+ MPDA.runCommand mpdCommand >> vimusAction l+ where+ (mpdCommand, vimusAction) = action l++ consSong x xs = case x of+ MPD.LsSong song -> song : xs+ _ -> xs++type SongList = ListWidget SongFormat MPD.Song++-- |+-- This consists of an MPD command and a Vimus action. The MPD command is run+-- before the Vimus action.+--+-- The Vimus action takes a `SongList`, so that we can pass an up-to-date list+-- if the action is applied to the playlist.+type SongListAction = SongList -> (MPDA.Command (), SongList -> Vimus SongList)++addAction :: SongListAction+addAction l = (+ for_ songs (MPDA.add . MPD.sgFilePath)+ , postAdd (length songs)+ )+ where+ songs = ListWidget.selected l++insertAction :: Int -> SongListAction+insertAction pos l = (+ for_ (zip songs $ map Just [pos..]) (uncurry MPDA.addId)+ , postAdd (length songs)+ )+ where+ songs = map MPD.sgFilePath $ ListWidget.selected l++songListHandler :: ListWidget SongFormat MPD.Song -> Event -> Vimus (ListWidget SongFormat MPD.Song)+songListHandler l ev = case ev of+ EvMoveAlbumNext -> do+ case ListWidget.select l of+ Just song -> return (ListWidget.moveDownWhile (sameAlbum song) l)+ Nothing -> return l++ EvMoveAlbumPrev -> do+ case ListWidget.select $ ListWidget.moveUp l of+ Just song -> return (ListWidget.moveUpWhile (sameAlbum song) l)+ Nothing -> return l++ EvCopy -> do+ writeCopyRegister $ pure (map MPD.sgFilePath $ ListWidget.selected l)+ return $ ListWidget.noVisual False l++ _ -> handleEvent l ev+ where+ sameAlbum a b = getAlbums a == getAlbums b && sgDirectory a == sgDirectory b+ where+ sgDirectory = dropFileName . MPD.toString . MPD.sgFilePath+ getAlbums = fromMaybe [] . Map.lookup MPD.Album . MPD.sgTags++postAdd :: (Searchable a, Renderable a) => Int -> ListWidget f a -> Vimus (ListWidget f a)+postAdd n l =+ -- Note: This behaves correctly for both+ --+ -- * if one item is selected+ -- * and the cursor is on a single item (:novisual)+ --+ -- (if one item is selected, it stays on the current song. In :novisual it+ -- moves down).+ --+ -- But this is not obvious and may easily break.+ --+ -- FIXME: Do we want to introduce test cases at this point?+ return $ ListWidget.noVisual False $ (if n == 1 then ListWidget.moveDown else id) l++newtype BrowserWidget = BrowserWidget (ListWidget SongFormat Content)++instance Widget BrowserWidget where+ render (BrowserWidget w) = render w+ currentItem (BrowserWidget w) = ListWidget.select w+ searchItem (BrowserWidget w) o t = BrowserWidget (searchItem w o t)+ filterItem (BrowserWidget w) t = BrowserWidget (filterItem w t)++ handleEvent (BrowserWidget l) ev = BrowserWidget <$> case ev of++ -- FIXME: Can we construct a data structure from `songs_` and use this for+ -- the browser instead of doing MPD.lsInfo on every EvMoveIn?+ EvLibraryChanged _ {- songs_ -} -> do+ songs <- MPD.lsInfo ""+ let new = ListWidget.update (==) l (map toContent songs)+ moveInMany (ListWidget.breadcrumbs l) new++ EvDefaultAction -> do+ case ListWidget.select l of+ Just item -> case item of+ Dir _ -> moveIn l+ PList _ -> moveIn l+ Song song -> MPD.addId (MPD.sgFilePath song) Nothing >>= MPD.playId >> return l+ PListSong p i _ -> addPlaylistSong p i >>= MPD.playId >> return l+ Nothing -> return l++ EvMoveIn -> moveIn l++ EvMoveOut -> do+ case ListWidget.getParent l of+ Just p -> return p+ Nothing -> return l++ EvAdd -> do+ -- FIXME: use Applicative style....+ let items = ListWidget.selected l+ forM_ items $ \item -> do+ case item of+ Dir path -> MPD.add path+ PList plst -> MPD.load plst+ Song song -> MPD.add (MPD.sgFilePath song)+ PListSong p i _ -> void $ addPlaylistSong p i+ postAdd (length items) l++ EvCopy -> do+ writeCopyRegister . fmap concat . MPDA.runCommand $+ for (ListWidget.selected l) $ \item ->+ case item of+ Dir path -> MPDA.listAll path+ Song song -> pure [MPD.sgFilePath song]+ PList {} -> pure []+ PListSong {} -> pure []++ return $ ListWidget.noVisual False l++ EvChangeSongFormat format ->+ return (ListWidget.setElementsFormat format l)++ _ -> handleEvent l ev+ where+ moveInMany :: [Content] -> ListWidget SongFormat Content -> Vimus (ListWidget SongFormat Content)+ moveInMany [] widget = return widget+ moveInMany (x:xs) widget = do+ case ListWidget.moveTo x widget of+ Just w -> if null xs+ then return w+ else moveIn w >>= moveInMany xs+ Nothing -> return widget++ moveIn :: ListWidget SongFormat Content -> Vimus (ListWidget SongFormat Content)+ moveIn w = case ListWidget.select w of+ Nothing -> return w+ Just item -> do+ case item of+ Dir path -> do+ new <- map toContent `fmap` MPD.lsInfo path+ return (ListWidget.newChild new w)+ PList path -> do+ new <- zipWith (PListSong path) [0..] `fmap` MPD.listPlaylistInfo path+ return (ListWidget.newChild new w)+ Song {} -> return w+ PListSong {} -> return w+++newtype LogWidget = LogWidget (ListWidget () LogMessage)++instance Widget LogWidget where+ render (LogWidget w) = render w+ currentItem _ = Nothing+ searchItem (LogWidget w) o t = LogWidget (searchItem w o t)+ filterItem (LogWidget w) t = LogWidget (filterItem w t)+ handleEvent (LogWidget widget) ev = LogWidget <$> case ev of+ EvLogMessage m -> return $ ListWidget.append widget m+ _ -> handleEvent widget ev+++-- | Used for autocompletion.+autoComplete :: CompletionFunction+autoComplete = completeCommand commands++commands :: [Command]+commands = [+ command "help" "display a list of all commands, and their current keybindings" $ do+ macroGuesses <- Macro.guessCommands commandNames <$> getMacros+ addTab (Other "Help") (makeHelpWidget commands macroGuesses) AutoClose++ , command "log" "show the error log" $ do+ messages <- gets logMessages+ let widget = ListWidget.moveLast (ListWidget.new $ reverse messages)+ addTab (Other "Log") (AnyWidget . LogWidget $ widget) AutoClose++ , command "map" "display a list of all commands that are currently bound to keys" $ do+ showMappings++ , command "map" "display the command that is currently bound to the key {name}" $ do+ showMapping++ , command "map" [help|+ Bind the command {expansion} to the key {name}. The same command may+ be bound to different keys.+ |] $ do+ addMapping++ , command "unmap" "remove the binding currently bound to the key {name}" $ do+ \(MacroName m) -> removeMacro m++ , command "mapclear" "" $ do+ clearMacros++ , command "exit" "exit vimus" $ do+ eval "quit"++ , command "quit" "exit vimus" $ do+ liftIO exitSuccess :: Vimus ()++ , command "close" "close the current window (not all windows can be closed)" $ do+ void closeTab++ , command "source" "read the file {path} and interprets all lines found there as if they were entered as commands." $ do+ \(Path p) -> liftIO (expandHome p) >>= either printError source_++ , command "runtime" "" $+ \(Path p) -> liftIO (getDataFileName p) >>= source_++ , command "color" "define the fore- and background color for a thing on the screen." $ do+ \color fg bg -> liftIO (defineColor color fg bg) :: Vimus ()++ , command "repeat" "set the playlist option *repeat*. When *repeat* is set, the playlist will start over when the last song has finished playing." $ do+ MPD.repeat True :: Vimus ()++ , command "norepeat" "Unset the playlist option *repeat*." $ do+ MPD.repeat False :: Vimus ()++ , command "consume" "set the playlist option *consume*. When *consume* is set, songs that have finished playing are automatically removed from the playlist." $ do+ MPD.consume True :: Vimus ()++ , command "noconsume" "Unset the playlist option *consume*." $ do+ MPD.consume False :: Vimus ()++ , command "random" "set the playlist option *random*. When *random* is set, songs in the playlist are played in random order." $ do+ MPD.random True :: Vimus ()++ , command "norandom" "Unset the playlist option *random*." $ do+ MPD.random False :: Vimus ()++ , command "single" "Set the playlist option *single*. When *single* is set, playback does not advance automatically to the next item in the playlist. Combine with *repeat* to repeatedly play the same song." $ do+ MPD.single True :: Vimus ()++ , command "nosingle" "Unset the playlist option *single*." $ do+ MPD.single False :: Vimus ()++ , command "autotitle" "Set the *autotitle* option. When *autotitle* is set, the console window title is automatically set to the currently playing song." $ do+ setAutoTitle True++ , command "noautotitle" "Unset the *autotitle* option." $ do+ setAutoTitle False++ , command "volume" "[+-]<num> set volume to <num> or adjust by [+-] num" $ do+ volume :: Volume -> Vimus ()++ , command "toggle-repeat" "Toggle the *repeat* option." $ do+ MPD.status >>= MPD.repeat . not . MPD.stRepeat :: Vimus ()++ , command "toggle-consume" "Toggle the *consume* option." $ do+ MPD.status >>= MPD.consume . not . MPD.stConsume :: Vimus ()++ , command "toggle-random" "Toggle the *random* option." $ do+ MPD.status >>= MPD.random . not . MPD.stRandom :: Vimus ()++ , command "toggle-single" "Toggle the *single* option." $ do+ MPD.status >>= MPD.single . not . MPD.stSingle :: Vimus ()++ , command "set-library-path" "While MPD knows where your songs are stored, vimus doesn't. If you want to use the *%* feature of the command :! you need to tell vimus where your songs are stored." $ do+ \(Path p) -> setLibraryPath p++ , command "next" "stop playing the current song, and starts the next one" $ do+ MPD.next :: Vimus ()++ , command "previous" "stop playing the current song, and starts the previous one" $ do+ MPD.previous :: Vimus ()++ , command "toggle" "toggle between play and pause" $ do+ MPDE.toggle :: Vimus ()++ , command "stop" "stop playback" $ do+ MPD.stop :: Vimus ()++ , command "update" "tell MPD to update the music database. You must update your database when you add or delete files in your music directory, or when you edit the metadata of a song. MPD will only rescan a file already in the database if its modification time has changed." $ do+ void (MPD.update Nothing) :: Vimus ()++ , command "rescan" "" $ do+ void (MPD.rescan Nothing) :: Vimus ()++ , command "clear" "delete all songs from the playlist" $ do+ MPD.clear :: Vimus ()++ , command "search-next" "jump to the next occurrence of the search string in the current window"+ searchNext++ , command "search-prev" "jump to the previous occurrence of the search string in the current window"+ searchPrev+++ , command "window-library" "open the *Library* window" $+ selectTab Library++ , command "window-playlist" "open the *Playlist* window" $+ selectTab Playlist++ , command "window-search" "open the *SearchResult* window" $+ selectTab SearchResult++ , command "window-browser" "open the *Browser* window" $+ selectTab Browser++ , command "window-next" "open the window to the right of the current one"+ nextTab++ , command "window-prev" "open the window to the left of the current one"+ previousTab++ , command "!" "execute {cmd} on the system shell. See chapter \"Using an external tag editor\" for an example."+ runShellCommand++ , command "seek" "jump to the given position in the current song"+ seek++ , command "visual" "start visual selection" $+ sendEventCurrent EvVisual++ , command "novisual" "cancel visual selection" $+ sendEventCurrent EvNoVisual++ -- Remove current song from playlist+ , command "remove" "remove the song under the cursor from the playlist" $+ sendEventCurrent EvRemove++ , command "paste" "add the last deleted song after the selected song in the playlist" $+ sendEventCurrent EvPaste++ , command "paste-prev" "" $+ sendEventCurrent EvPastePrevious++ , command "copy" "" $+ sendEventCurrent EvCopy++ , command "shuffle" "shuffle the current playlist" $ do+ MPD.shuffle Nothing :: Vimus ()++ , command "add" "append selected songs to the end of the playlist" $ do+ sendEventCurrent EvAdd++ -- insert a song right after the current song+ , command "insert" [help|+ inserts a song to the playlist. The song is inserted after the currently+ playing song.+ |] $ do+ st <- MPD.status+ case MPD.stSongPos st of+ Just n -> do+ -- there is a current song, insert after+ sendEventCurrent (EvInsert (n + 1))+ _ -> do+ -- there is no current song, just add+ sendEventCurrent EvAdd++ -- Playlist: play selected song+ -- Library: add song to playlist and play it+ -- Browse: either add song to playlist and play it, or :move-in+ , command "default-action" [help|+ depending on the item under the cursor, somthing different happens:++ - *Playlist* start playing the song under the cursor++ - *Library* append the song under the cursor to the playlist and start playing it++ - *Browser* on a song: append the song to the playlist and play it. On a directory: go down to that directory.+ |] $ do+ sendEventCurrent EvDefaultAction++ , command "add-album" "add all songs of the album of the selected song to the playlist" $ do+ songs <- fromCurrent MPD.Album [MPD.Disc, MPD.Track]+ maybe (printError "Song has no album metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs++ , command "add-artist" "add all songs of the artist of the selected song to the playlist" $ do+ songs <- fromCurrent MPD.Artist [MPD.Date, MPD.Album, MPD.Disc, MPD.Track]+ maybe (printError "Song has no artist metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs++ -- movement+ , command "move-up" "move the cursor one line up" $+ sendEventCurrent EvMoveUp++ , command "move-down" "move the cursor one line down" $+ sendEventCurrent EvMoveDown++ , command "move-album-prev" "move the cursor up to the first song of an album" $+ sendEventCurrent EvMoveAlbumPrev++ , command "move-album-next" "move the cursor down to the first song of an album" $+ sendEventCurrent EvMoveAlbumNext++ , command "move-in" "go down one level the directory hierarchy in the *Browser* window" $+ sendEventCurrent EvMoveIn++ , command "move-out" "go up one level in the directory hierarchy in the *Browser* window" $+ sendEventCurrent EvMoveOut++ , command "move-first" "go to the first line in the current window" $+ sendEventCurrent EvMoveFirst++ , command "move-last" "go to the last line in the current window" $+ sendEventCurrent EvMoveLast++ , command "scroll-up" "scroll the contents of the current window up one line" $+ sendEventCurrent (EvScroll (-1))++ , command "scroll-down" "scroll the contents of the current window down one line" $+ sendEventCurrent (EvScroll 1)++ , command "scroll-page-up" "scroll the contents of the current window up one page" $+ pageScroll >>= sendEventCurrent . EvScroll . negate++ , command "scroll-half-page-up" "scroll the contents of the current window up one half page" $+ pageScroll >>= sendEventCurrent . EvScroll . negate . (`div` 2)++ , command "scroll-page-down" "scroll the contents of the current window down one page" $+ pageScroll >>= sendEventCurrent . EvScroll++ , command "scroll-half-page-down" "scroll the contents of the current window down one half page" $+ pageScroll >>= sendEventCurrent . EvScroll . (`div` 2)++ , command "song-format" "set song rendering format" $+ sendEvent . EvChangeSongFormat+ ]++getCurrentPath :: Vimus (Maybe FilePath)+getCurrentPath = do+ mBasePath <- getLibraryPath+ mPath <- withCurrentItem $ \item -> return . Just $ case item of+ Dir path -> MPD.toString path+ PList l -> MPD.toString l+ Song song -> MPD.toString (MPD.sgFilePath song)+ PListSong _ _ s -> MPD.toString (MPD.sgFilePath s)++ return $ (mBasePath `append` mPath) <|> mBasePath+ where+ append = liftA2 (</>)+++expandCurrentPath :: String -> Maybe String -> Either String String+expandCurrentPath s mPath = go s+ where+ go "" = return ""+ go ('\\':'\\':xs) = ('\\':) `fmap` go xs+ go ('\\':'%':xs) = ('%':) `fmap` go xs+ go ('%':xs) = case mPath of+ Nothing -> Left "Path to music library is not set, hence % can not be used!"+ Just p -> (posixEscape p ++) `fmap` go xs+ go (x:xs) = (x:) `fmap` go xs++-- | Evaluate command with given name+eval :: String -> Vimus ()+eval input = case parseCommand input of+ ("", "") -> return ()+ (c, args) -> case match c commandNames of+ None -> printError $ printf "unknown command %s" c+ Match x -> either printError id $ runAction (commandMap ! x) args+ Ambiguous xs -> printError $ printf "ambiguous command %s, could refer to: %s" c $ intercalate ", " xs++-- | A mapping from `commandName` to `commandAction`.+--+-- Actions with the same command name are combined with (<|>).+commandMap :: Map String VimusAction+commandMap = foldr f Map.empty commands+ where f c = Map.insertWith' (<|>) (commandName c) (commandAction c)++commandNames :: [String]+commandNames = Map.keys commandMap++-- | Run command with given name+runCommand :: String -> Vimus ()+runCommand c = eval c `catchError` (printError . show)++-- | Source file with given name.+--+-- TODO: proper error detection/handling+--+source :: String -> Vimus ()+source name = do+ rc <- lines `fmap` liftIO (readFile name)+ forM_ rc $ \line -> case strip line of++ -- skip empty lines+ "" -> return ()++ -- skip comments+ '#':_ -> return ()++ -- run commands+ s -> runCommand s++-- | A safer version of `source` that first checks whether the file exists.+source_ :: String -> Vimus ()+source_ name = do+ exists <- liftIO (doesFileExist name)+ if exists+ then do+ source name+ else do+ printError ("file " ++ show name ++ " not found")+++------------------------------------------------------------------------+-- commands++newtype Path = Path String++instance Argument Path where+ argumentSpec = ArgumentSpec "path" noCompletion (Path <$> argumentParser)++newtype ShellCommand = ShellCommand String++instance Argument ShellCommand where+ argumentSpec = ArgumentSpec "cmd" noCompletion parser+ where+ parser = ShellCommand <$> do+ r <- takeInput+ when (null r) $ do+ missingArgument (undefined :: ShellCommand)+ return r++runShellCommand :: ShellCommand -> Vimus ()+runShellCommand (ShellCommand cmd) = (expandCurrentPath cmd <$> getCurrentPath) >>= either printError action+ where+ action s = liftIO $ do+ void endwin+ e <- system s+ case e of+ ExitSuccess -> return ()+ ExitFailure n -> putStrLn ("shell returned " ++ show n)+ void getChar++newtype MacroName = MacroName String+ deriving (Eq, Show)+++instance Argument MacroName where+ argumentSpec = ArgumentSpec "name" complete parser+ where+ parser = MacroName <$> (argumentParser >>= expandKeys_)++ -- a lifted version of expandKeys+ expandKeys_ :: String -> Parser String+ expandKeys_ = either (specificArgumentError . show) return . expandKeys++ complete input = case expandKeys input of+ Left (UnterminatedKeyReference k) -> (\x -> input ++ drop (length k) x) <$> completeOptions_ ">" keyNames k+ _ -> Left []++newtype MacroExpansion = MacroExpansion String++instance Argument MacroExpansion where+ argumentSpec = ArgumentSpec "expansion" noCompletion parser+ where+ parser = MacroExpansion <$> do+ e <- takeInput+ when (null e) $ do+ missingArgument (undefined :: MacroExpansion)++ either (specificArgumentError . show) return (expandKeys e)++showMappings :: Vimus ()+showMappings = do+ macroHelp <- Macro.helpAll <$> getMacros+ let helpWidget = AnyWidget $ ListWidget.new (sort macroHelp)+ addTab (Other "Mappings") helpWidget AutoClose++showMapping :: MacroName -> Vimus ()+showMapping (MacroName m) =+ getMacros >>= either printError printMessage . Macro.help m++-- | Add define a new mapping.+addMapping :: MacroName -> MacroExpansion -> Vimus ()+addMapping (MacroName m) (MacroExpansion e) = addMacro m e++newtype Seconds = Seconds MPD.Seconds++instance Argument Seconds where+ argumentSpec = ArgumentSpec "seconds" noCompletion parser+ where+ parser = Seconds <$> argumentParser++seek :: Seconds -> Vimus ()+seek (Seconds delta) = do+ st <- MPD.status+ let (current, total) = fromMaybe (0, 0) (MPD.stTime st)+ let newTime = round current + delta+ if newTime < 0+ then do+ -- seek within previous song+ case MPD.stSongPos st of+ Just currentSongPos -> unless (currentSongPos == 0) $ do+ previousItem <- MPD.playlistInfo $ Just (currentSongPos - 1)+ case previousItem of+ song : _ -> maybeSeek (MPD.sgId song) (MPD.sgLength song + newTime)+ _ -> return ()+ _ -> return ()+ else if newTime > total then+ -- seek within next song+ maybeSeek (MPD.stNextSongID st) (newTime - total)+ else+ -- seek within current song+ maybeSeek (MPD.stSongID st) newTime+ where+ maybeSeek (Just songId) time = MPD.seekId songId time+ maybeSeek Nothing _ = return ()++-- | Volume argument for the 'volume' command.+data Volume =+ Volume Int -- ^ Exact volume value, 0-100.+ | VolumeOffset Int -- ^ Offset from current volume.+ deriving (Eq, Show)++instance Argument Volume where+ argumentSpec = ArgumentSpec "volume" noCompletion parseVolume++parseVolume :: Parser Volume+parseVolume = do+ r <- takeWhile1 (not . isSpace) <|> missingArgument proxy+ maybe (invalidArgument proxy r) return (readVolume r)+ where+ proxy = undefined :: Volume++readVolume :: String -> Maybe Volume+readVolume s = case s of+ ('+':n) -> VolumeOffset <$> offsetValue n+ ('-':_) -> VolumeOffset <$> offsetValue s+ _ -> Volume <$> volumeValue s+ where+ offsetValue x = readMaybe x >>= inRange (-100) 100+ volumeValue x = readMaybe x >>= inRange 0 100+ inRange l h x = guard (l <= x && x <= h) >> return x++-- | Set volume, or increment it by fixed amount.+volume :: Volume -> Vimus ()+volume (Volume v) = MPD.setVolume v+volume (VolumeOffset i) = currentVolume >>= maybe (return ()) (\v -> MPD.setVolume (adjust (v + i)))+ where+ currentVolume = MPD.stVolume <$> MPD.status+ adjust x+ | x > 100 = 100+ | x < 0 = 0+ | otherwise = x+++-- | Get all 'MPD.Song's with the same metadata as the selected 'MPD.Song',+-- sorted according to provided list of tags+fromCurrent :: MPD.Metadata -> [MPD.Metadata] -> Vimus (Maybe [MPD.Song])+fromCurrent metadata tags = withCurrentSong $ \song ->+ case Map.lookup metadata $ MPD.sgTags song of+ Just xs ->+ Just . metaSorted tags . concat <$> mapM (MPD.find . (metadata =?)) xs+ Nothing ->+ return Nothing++-- | Sort 'MPD.Songs' according to provided list of tags+metaSorted :: [MPD.Metadata] -> [MPD.Song] -> [MPD.Song]+metaSorted tags = sortBy (foldMap comparingTag tags)++-- | Compare two 'MPD.Song's on tag+comparingTag :: MPD.Metadata -> MPD.Song -> MPD.Song -> Ordering+comparingTag tag = case tag of+ MPD.Date -> comparing numericTag+ MPD.Disc -> comparing numericTag+ MPD.Track -> comparing numericTag+ _ -> comparing stringTag+ where+ stringTag :: MPD.Song -> Maybe String+ stringTag s =+ Map.lookup tag (MPD.sgTags s) >>= listToMaybe >>= Just . MPD.toString++ numericTag :: MPD.Song -> Maybe Integer+ numericTag s =+ Map.lookup tag (MPD.sgTags s) >>= listToMaybe >>= readMaybe . MPD.toString
+ src/Command/Completion.hs view
@@ -0,0 +1,69 @@+module Command.Completion (+ completeCommand+, parseCommand+, completeOptions+, completeOptions_+) where++import Data.List+import Data.Char++import Util+import Command.Type++completeCommand :: [Command] -> CompletionFunction+completeCommand commands input_ = (pre ++) `fmap` case parseCommand_ input of+ (c, "") -> completeCommandName c+ (c, args) ->+ -- the list of matches is reversed, so that completion is done for the last+ -- command in the list+ case reverse $ filter ((== c) . commandName) commands of+ x:_ -> (c ++) `fmap` completeArguments (commandArguments x) args+ [] -> Left []+ where+ (pre, input) = span isSpace input_++ -- a completion function for command names+ completeCommandName :: CompletionFunction+ completeCommandName = completeOptions (map commandName commands)++completeArguments :: [ArgumentInfo] -> CompletionFunction+completeArguments = go+ where+ go specs_ input_ = (pre ++) `fmap` case specs_ of+ [] -> Left []+ spec:specs -> case break isSpace input of+ (arg, "") -> argumentInfoComplete spec arg+ (arg, args) -> (arg ++) `fmap` go specs args+ where+ (pre, input) = span isSpace input_++-- | Create a completion function from a list of possibilities.+completeOptions :: [String] -> CompletionFunction+completeOptions = completeOptions_ " "++-- | Like `completeOptions`, but terminates completion with a given string+-- instead of " ".+completeOptions_ :: String -> [String] -> CompletionFunction+completeOptions_ terminator options input = case filter (isPrefixOf input) options of+ [x] -> Right (x ++ terminator)+ xs -> case commonPrefix $ map (drop $ length input) xs of+ "" -> Left xs+ ys -> Right (input ++ ys)+++-- | Split given input into a command name and a rest (the arguments).+--+-- Whitespace in front of the command name and the arguments is striped.+parseCommand :: String -> (String, String)+parseCommand input = (name, dropWhile isSpace args)+ where (name, args) = parseCommand_ (dropWhile isSpace input)++-- | Like `parseCommand`, but assume that input starts with a non-whitespace+-- character, and retain whitespace in front of the arguments.+parseCommand_ :: String -> (String, String)+parseCommand_ input = (name, args)+ where+ (name, args) = case input of+ '!':xs -> ("!", xs)+ xs -> break isSpace xs
+ src/Command/Core.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-}+module Command.Core (+ Command+, commandName+, commandAction+, commandSynopsis+, Argument (..)+, ArgumentSpec (..)+, noCompletion+, argumentParser+, Action (..)+, VimusAction+, runAction+, command++-- * Helpers for defining @Argument@ instances+, missingArgument+, invalidArgument+, specificArgumentError++-- * exported for testing+, readParser+, IsAction (..)+) where++import Control.Applicative+import Control.Monad (unless)+import Data.Char++import Vimus (Vimus)+import Text.Read (readMaybe)+import WindowLayout (WindowColor(..), defaultColor)+import UI.Curses (Color, black, red, green, yellow, blue, magenta, cyan, white)+import Command.Type+import Command.Help () -- for the (IsString Help) instance+import Command.Completion+import Command.Parser+import Song.Format (SongFormat)+import qualified Song.Format as SongFormat+import qualified Song++runAction :: Action a -> String -> Either String a+runAction action s = either (Left . show) (Right . fst) $ runParser (unAction action <* endOfInput) s+++class IsAction a b where+ toAction :: a -> Action b+ actionArguments :: a -> b -> [ArgumentInfo]++instance IsAction a a where++ toAction a = Action $ do+ r <- takeInput+ unless (null r) $ do+ parserFail (SuperfluousInput r)+ return a++ actionArguments _ _ = []++instance (Argument a, IsAction b c) => IsAction (a -> b) c where+ toAction action = Action $ (argumentParser <* skipWhile isSpace) >>= unAction . toAction . action+ actionArguments _ _ = mkArgumentInfo (argumentSpec :: (ArgumentSpec a)) : actionArguments (undefined :: b) (undefined :: c)++-- | Get help text for given command.+commandSynopsis :: Command -> String+commandSynopsis c = unwords $ commandName c : map (\x -> "{" ++ argumentInfoName x ++ "}") (commandArguments c)++-- | Define a command.+command :: forall a . IsAction a (Vimus ()) => String -> Help -> a -> Command+command name description action = Command name description (actionArguments action (undefined :: Vimus ())) (toAction action)++-- | Create an ArgumentInfo from given ArgumentSpec.+mkArgumentInfo :: ArgumentSpec a -> ArgumentInfo+mkArgumentInfo arg = ArgumentInfo {+ argumentInfoName = argumentSpecName arg+ , argumentInfoComplete = argumentSpecComplete arg+ }++-- | Like ArgumentInfo, but includes a parser for the argument.+data ArgumentSpec a = ArgumentSpec {+ argumentSpecName :: String+, argumentSpecComplete :: CompletionFunction+, argumentSpecParser :: Parser a+}++-- | An argument.+class Argument a where+ -- | A parser for this argument, together with a description.+ --+ -- The description provides information about the argument, that can be used+ -- for command-line completion and online help.+ --+ -- The parser can assume that the input is either empty or starts with a+ -- non-whitespace character.+ argumentSpec :: ArgumentSpec a+++argumentParser :: Argument a => Parser a+argumentParser = argumentSpecParser argumentSpec++argumentName :: forall a . Argument a => a -> String+argumentName _ = argumentSpecName (argumentSpec :: ArgumentSpec a)++-- | A parser for arguments in the Read class.+readParser :: forall a . (Read a, Argument a) => Parser a+readParser = mkParser readMaybe++-- | A helper function for constructing argument parsers.+mkParser :: forall a . (Argument a) => (String -> Maybe a) -> Parser a+mkParser f = do+ r <- takeWhile1 (not . isSpace) <|> missingArgument (undefined :: a)+ maybe (invalidArgument (undefined ::a) r) return (f r)++-- | A failing parser that indicates a missing argument.+missingArgument :: Argument a => a -> Parser b+missingArgument = parserFail . MissingArgument . argumentName++-- | A failing parser that indicates an invalid argument.+invalidArgument :: Argument a => a -> Value -> Parser b+invalidArgument t = parserFail . InvalidArgument (argumentName t)++-- | A failing parser that indicates a specific error. It takes precedence+-- over any other kind of error.+specificArgumentError :: String -> Parser b+specificArgumentError = parserFail . SpecificArgumentError++instance Argument Int where+ argumentSpec = ArgumentSpec "int" noCompletion readParser++instance Argument Integer where+ argumentSpec = ArgumentSpec "integer" noCompletion readParser++instance Argument Float where+ argumentSpec = ArgumentSpec "float" noCompletion readParser++instance Argument Double where+ argumentSpec = ArgumentSpec "double" noCompletion readParser++instance Argument String where+ argumentSpec = ArgumentSpec "string" noCompletion (mkParser Just)++instance Argument SongFormat where+ argumentSpec = ArgumentSpec "songformat" noCompletion (SongFormat.parser Song.metaQueries)++-- | Create an ArgumentSpec from an association list.+mkArgumentSpec :: Argument a => String -> [(String, a)] -> ArgumentSpec a+mkArgumentSpec name values = ArgumentSpec name complete parser+ where+ parser = mkParser ((`lookup` values) . map toLower)+ complete = completeOptions (map fst values)++instance Argument WindowColor where+ argumentSpec = mkArgumentSpec "item" [+ ("main", MainColor)+ , ("ruler", RulerColor)+ , ("tab", TabColor)+ , ("input", InputColor)+ , ("playstatus", PlayStatusColor)+ , ("songstatus", SongStatusColor)+ , ("error", ErrorColor)+ , ("suggestions", SuggestionsColor)+ ]++instance Argument Color where+ argumentSpec = mkArgumentSpec "color" [+ ("default", defaultColor)+ , ("black", black)+ , ("red", red)+ , ("green", green)+ , ("yellow", yellow)+ , ("blue", blue)+ , ("magenta", magenta)+ , ("cyan", cyan)+ , ("white", white)+ ]
+ src/Command/Help.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Command.Help (+ Help (..)+, help+, commandShortHelp+, commandHelpText+) where++import Control.Monad+import Data.Maybe+import Data.String+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax++import Command.Type+import Util (strip)++-- | A `QuasiQuoter` for help text.+help :: QuasiQuoter+help = QuasiQuoter {+ quoteExp = lift . parseHelp+ , quotePat = error "Command.Help.help: quotePat is undefined!"+ , quoteType = error "Command.Help.help: quoteType is undefined!"+ , quoteDec = error "Command.Help.help: quoteDec is undefined!"+ }++instance Lift Help where+ lift (Help xs) = AppE `fmap` [|Help|] `ap` lift xs++instance IsString Help where+ fromString = parseHelp++-- | Parse help text.+parseHelp :: String -> Help+parseHelp = Help . go . map strip . lines+ where+ go l = case dropWhile null l of+ [] -> []+ xs -> let (ys, zs) = break null xs in (wordWrapping . unwords) ys ++ go zs++-- | Apply automatic word wrapping.+wordWrapping :: String -> [String]+wordWrapping = run . words+ where+ -- we start each recursion step at 2, this makes sure that each step+ -- consumes at least one word+ run = go 2+ go n xs+ | null xs = []+ | 60 < length (unwords ys) = let (as, bs) = splitAt (pred n) xs in unwords as : run bs+ | null zs = [unwords ys]+ | otherwise = go (succ n) xs+ where+ (ys, zs) = splitAt n xs++-- | The first line of the command description.+commandShortHelp :: Command -> String+commandShortHelp = fromMaybe "" . listToMaybe . unHelp . commandHelp_++commandHelpText :: Command -> [String]+commandHelpText = unHelp . commandHelp_
+ src/Command/Parser.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE DeriveFunctor #-}+module Command.Parser where++import Prelude hiding (takeWhile)+import Data.List (intercalate)+import Control.Monad+import Control.Applicative++type Name = String+type Value = String++-- | Errors are ordered from less specific to more specific. More specific+-- errors take precedence over less specific ones.+data ParseError =+ Empty+ | ParseError String+ | SuperfluousInput Value+ | MissingArgument Name+ | InvalidArgument Name Value+ | SpecificArgumentError String+ deriving (Eq, Ord)++instance Show ParseError where+ show e = case e of+ Empty -> "Control.Applicative.Alternative.empty"+ ParseError err -> "parse error: " ++ err+ SuperfluousInput input -> case words input of+ [] -> "superfluous input: " ++ show input+ [x] -> "unexpected argument: " ++ show x+ xs -> "unexpected arguments: " ++ intercalate ", " (map show xs)+ MissingArgument name -> "missing required argument: " ++ name+ InvalidArgument name value -> "argument " ++ show value ++ " is not a valid " ++ name+ SpecificArgumentError err -> err++newtype Parser a = Parser {runParser :: String -> Either ParseError (a, String)}+ deriving Functor++instance Applicative Parser where+ pure = return+ (<*>) = ap++instance Monad Parser where+ fail = parserFail . ParseError+ return a = Parser $ \input -> Right (a, input)+ p1 >>= p2 = Parser $ \input -> runParser p1 input >>= uncurry (runParser . p2)++instance Alternative Parser where+ empty = parserFail Empty+ p1 <|> p2 = Parser $ \input -> case runParser p1 input of+ Left err -> either (Left . max err) (Right) (runParser p2 input)+ x -> x++-- | Recognize a character that satisfies a given predicate.+satisfy :: (Char -> Bool) -> Parser Char+satisfy p = Parser go+ where+ go (x:xs)+ | p x = Right (x, xs)+ | otherwise = (Left . ParseError) ("satisfy: unexpected " ++ show x)+ go "" = (Left . ParseError) "satisfy: unexpected end of input"++-- | Recognize a given character.+char :: Char -> Parser Char+char c = satisfy (== c)++-- | Recognize a given string.+string :: String -> Parser String+string = mapM char++parserFail :: ParseError -> Parser a+parserFail = Parser . const . Left++takeWhile :: (Char -> Bool) -> Parser String+takeWhile p = Parser $ Right . span p++takeWhile1 :: (Char -> Bool) -> Parser String+takeWhile1 p = Parser go+ where+ go "" = (Left . ParseError) "takeWhile1: unexpected end of input"+ go (x:xs)+ | p x = let (ys, zs) = span p xs in Right (x:ys, zs)+ | otherwise = (Left . ParseError) ("takeWhile1: unexpected " ++ show x)++skipWhile :: (Char -> Bool) -> Parser ()+skipWhile p = takeWhile p *> pure ()++-- | Consume and return all remaining input.+takeInput :: Parser String+takeInput = Parser $ \input -> Right (input, "")++-- | Succeed only if all input has been consumed.+endOfInput :: Parser ()+endOfInput = Parser $ \input -> case input of+ "" -> Right ((), "")+ xs -> (Left . ParseError) ("endOfInput: remaining input " ++ show xs)
+ src/Command/Type.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Command.Type (+ module Command.Type+, CompletionFunction+, noCompletion+) where++import Control.Applicative++import Vimus+import Input (CompletionFunction, noCompletion)+import Command.Parser++newtype Action a = Action {unAction :: Parser a}+ deriving (Functor, Applicative, Alternative)++type VimusAction = Action (Vimus ())++newtype Help = Help {unHelp :: [String]}++data ArgumentInfo = ArgumentInfo {+ argumentInfoName :: String+, argumentInfoComplete :: CompletionFunction+}++-- | A command.+data Command = Command {+ commandName :: String+, commandHelp_ :: Help+, commandArguments :: [ArgumentInfo]+, commandAction :: VimusAction+}
+ src/Content.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Content (+ Content(..)+, toContent+, Searchable(..)+) where++import qualified Data.Map as Map+import qualified Network.MPD as MPD hiding (withMPD)+import qualified System.FilePath as FilePath++import Widget.Type+import Song.Format (SongFormat(..))++pathFileName :: MPD.Path -> String+pathFileName = FilePath.takeFileName . MPD.toString++plFileName :: MPD.PlaylistName -> String+plFileName = FilePath.takeFileName . MPD.toString++-- | Define a new Content type to replace MPD.LsResult+data Content =+ Dir MPD.Path+ | Song MPD.Song+ | PList MPD.PlaylistName+ | PListSong MPD.PlaylistName Int MPD.Song+ deriving (Show, Eq)++toContent :: MPD.LsResult -> Content+toContent r = case r of+ MPD.LsSong song -> Song song+ MPD.LsPlaylist list -> PList list+ MPD.LsDirectory path -> Dir path++instance Renderable MPD.Song where+ type Format MPD.Song = SongFormat+ renderItem (SongFormat format) song = renderItem () (format song)++instance Renderable Content where+ type Format Content = SongFormat+ renderItem format item = case item of+ Song song -> renderItem format song+ Dir path -> renderItem () $ "[" ++ pathFileName path ++ "]"+ PList list -> renderItem () $ "(" ++ plFileName list ++ ")"+ PListSong _ _ song -> renderItem format song++class Searchable a where+ searchTags :: a -> [String]++instance Searchable String where+ searchTags = return++instance Searchable Content where+ searchTags item = case item of+ Dir path -> [pathFileName path]+ PList path -> [plFileName path]+ Song song -> searchTags song+ PListSong _ _ song -> searchTags song++instance Searchable MPD.Song where+ searchTags song = (pathFileName $ MPD.sgFilePath song) : (map MPD.toString $ concat $ Map.elems $ MPD.sgTags song)
+ src/Data/List/Pointed.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveFunctor #-}+module Data.List.Pointed where++data PointedList a = PointedList ![a] !a ![a]+ deriving Functor++-- | Return the focused element.+focus :: PointedList a -> a+focus (PointedList _ x _) = x++-- | Modify the focused element.+modify :: (a -> a) -> PointedList a -> PointedList a+modify f (PointedList xs c ys) = PointedList xs (f c) ys++goLeft :: PointedList a -> PointedList a+goLeft (PointedList (x:xs) c ys) = PointedList xs x (c:ys)+goLeft s = s++goRight :: PointedList a -> PointedList a+goRight (PointedList xs c (y:ys)) = PointedList (c:xs) y ys+goRight s = s++atEnd :: PointedList a -> Bool+atEnd (PointedList _ _ []) = True+atEnd _ = False++atStart :: PointedList a -> Bool+atStart (PointedList [] _ _) = True+atStart _ = False
+ src/Data/List/Zipper.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveFunctor #-}+module Data.List.Zipper where++data ListZipper a = ListZipper ![a] ![a]+ deriving Functor++empty :: ListZipper a+empty = ListZipper [] []++isEmpty :: ListZipper a -> Bool+isEmpty (ListZipper [] []) = True+isEmpty _ = False++{-+atEnd :: ListZipper a -> Bool+atEnd (ListZipper _ []) = True+atEnd _ = False++atStart :: ListZipper a -> Bool+atStart (ListZipper [] _) = True+atStart _ = False+-}++insertLeft :: a -> ListZipper a -> ListZipper a+insertLeft x (ListZipper xs ys) = ListZipper (x:xs) ys++{-+takeLeft :: ListZipper a -> Maybe a+takeLeft (ListZipper (x:_) _) = Just x+takeLeft _ = Nothing++takeRight :: ListZipper a -> Maybe a+takeRight (ListZipper _ (y:_)) = Just y+takeRight _ = Nothing+-}++dropLeft :: ListZipper a -> ListZipper a+dropLeft (ListZipper (_:xs) ys) = ListZipper xs ys+dropLeft s = s++dropRight :: ListZipper a -> ListZipper a+dropRight (ListZipper xs (_:ys)) = ListZipper xs ys+dropRight s = s++dropWhileLeft :: (a -> Bool) -> ListZipper a -> ListZipper a+dropWhileLeft f (ListZipper xs ys) = ListZipper (dropWhile f xs) ys++dropWhileRight :: (a -> Bool) -> ListZipper a -> ListZipper a+dropWhileRight f (ListZipper xs ys) = ListZipper xs (dropWhile f ys)++clearLeft, clearRight :: ListZipper a -> ListZipper a+clearLeft (ListZipper _ ys) = ListZipper [] ys+clearRight (ListZipper xs _) = ListZipper xs []++goLeft :: ListZipper a -> ListZipper a+goLeft (ListZipper (x:xs) ys) = ListZipper xs (x:ys)+goLeft s = s++goRight :: ListZipper a -> ListZipper a+goRight (ListZipper xs (y:ys)) = ListZipper (y:xs) ys+goRight s = s++goFirst :: ListZipper a -> ListZipper a+goFirst (ListZipper xs ys) = ListZipper [] (reverse xs ++ ys)++goLast :: ListZipper a -> ListZipper a+goLast (ListZipper xs ys) = ListZipper (reverse ys ++ xs) []++toList :: ListZipper a -> [a]+toList (ListZipper prev next) = reverse prev ++ next++-- | Create a zipper from given list, set focus at start.+fromList :: [a] -> ListZipper a+fromList s = ListZipper [] s
+ src/Input.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Input (+ InputT+, runInputT+, unGetString+, getChar+, getInputLine+, getInputLine_+, HistoryNamespace (..)+, CompletionFunction+, noCompletion++-- exported for testing+, readline+, getUnGetBuffer+) where++import Prelude hiding (getChar)+import Control.Applicative+import Control.Monad.State.Strict+import qualified Data.Char as Char+import Control.DeepSeq+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.List (intercalate)++import UI.Curses (Window)+import qualified UI.Curses as Curses+import UI.Curses.Key++import WindowLayout+import Key++import Data.List.Zipper as ListZipper+import Data.List.Pointed hiding (modify)+import qualified Data.List.Pointed as PointedList++-- | There two history stacks, one for commands and one for search.+data HistoryNamespace = SearchHistory | CommandHistory+ deriving (Eq, Ord)++data InputState m = InputState {+ get_wch :: m Char+, unGetBuffer :: !String+, history :: !(Map HistoryNamespace [String])++-- history is disabled if last input was taken from the unGetBuffer+, historyDisabled :: !Bool+}++newtype InputT m a = InputT (StateT (InputState m) m a)+ deriving (Functor, Applicative, Monad, MonadIO)++instance MonadTrans InputT where+ lift = InputT . lift++runInputT :: Monad m => m Char -> InputT m a -> m a+runInputT get_wch_ (InputT action) = evalStateT action (InputState get_wch_ "" Map.empty True)++getChar :: Monad m => InputT m Char+getChar = InputT $ do+ st <- get+ case unGetBuffer st of+ [] -> put st {historyDisabled = False} >> lift (get_wch st)+ x:xs -> put st {unGetBuffer = xs} >> return x++unGetString :: Monad m => String -> InputT m ()+unGetString s+ | null s = return ()+ | otherwise = InputT . modify $ \st -> st {historyDisabled = True, unGetBuffer = s ++ unGetBuffer st}++-- | This is only here so that test cases can inspect the unGetBuffer.+getUnGetBuffer :: Monad m => InputT m String+getUnGetBuffer = InputT (gets unGetBuffer)++-- | Add a line to the history stack.+addHistory :: Monad m => HistoryNamespace -> String -> InputT m ()+addHistory hstName x = InputT (modify f)+ where+ f st+ -- empty line, ignore+ | null x = st++ -- history is disabled, ignore+ | disabled = st++ -- duplicate, ignore+ | duplicate = st++ | otherwise = hst_ `deepseq` st {history = Map.insert hstName hst_ hstMap}+ where+ hstMap = history st+ hst = Map.findWithDefault [] hstName hstMap++ -- only keep 50 lines of history+ hst_ = take 50 (x:hst)++ disabled = historyDisabled st+ duplicate = maybe False (== x) (listToMaybe hst)++-- | Get the history stack for a given namespace.+getHistory :: Monad m => HistoryNamespace -> InputT m [String]+getHistory name = (fromMaybe [] . Map.lookup name) `liftM` InputT (gets history)++type CompletionFunction = String -> Either [String] String+type Suggestions = [String]+type InputBuffer = PointedList (ListZipper Char)+data EditResult = Accept String | Continue Suggestions InputBuffer | Cancel++noCompletion :: CompletionFunction+noCompletion = const (Left [])++edit :: CompletionFunction -> InputBuffer -> Char -> EditResult+edit complete buffer c+ | accept = (Accept . toList . focus) buffer+ | cancel = Cancel++ -- movement+ | left = continue ListZipper.goLeft+ | right = continue ListZipper.goRight+ | isFirst = continue goFirst+ | isLast = continue goLast++ -- editing+ | delete = continue dropRight+ | isBackspace = backspace+ | c == ctrlU = continue clearLeft+ | c == ctrlW = continue dropWordLeft++ -- history+ | previous = historyPrevious+ | next = historyNext++ -- completion+ | c == keyTab = autoComplete++ -- others+ | Char.isControl c = continue id+ | otherwise = continue (insertLeft c)+ where+ isBackspace = c == keyBackspace || c == '\DEL'++ accept = c == '\n' || c == keyEnter+ cancel = c == ctrlC || c == ctrlG || c == keyEsc++ left = c == ctrlB || c == keyLeft+ right = c == ctrlF || c == keyRight+ isFirst = c == ctrlA || c == keyHome+ isLast = c == ctrlE || c == keyEnd++ delete = c == ctrlD || c == keyDc++ previous = c == ctrlP || c == keyUp+ next = c == ctrlN || c == keyDown++ dropWordLeft = dropWhileLeft (not . Char.isSpace) . dropWhileLeft Char.isSpace++ backspace+ | isEmpty s = Cancel+ | otherwise = continue dropLeft+ where+ s = focus buffer++ historyPrevious+ | atEnd buffer = Continue [] buffer+ | otherwise = (Continue [] . PointedList.modify goLast . PointedList.goRight) buffer++ historyNext+ | atStart buffer = Continue [] buffer+ | otherwise = (Continue [] . PointedList.modify goLast . PointedList.goLeft) buffer++ autoComplete = case complete (reverse prev) of+ Right xs -> continue (const $ ListZipper (reverse xs) next_)+ Left suggestions -> Continue suggestions buffer+ where+ ListZipper prev next_ = focus buffer++ continue = Continue [] . (`PointedList.modify` buffer)+++-- | A tuple of current input, cursor position and suggestions.+type IntermediateResult = (Int, String, Suggestions)++-- | Read a line of user input.+--+-- Apply given action on each keystroke to intermediate result.+--+-- Return empty string on cancel.+readline :: Monad m => CompletionFunction -> HistoryNamespace -> (IntermediateResult -> InputT m ()) -> InputT m String+readline complete hstName onUpdate = getHistory hstName >>= go [] . PointedList [] ListZipper.empty . map fromList+ where+ go suggestions buffer = do+ let ListZipper prev next = focus buffer+ onUpdate (length prev, reverse prev ++ next, suggestions)+ c <- getChar+ case edit complete buffer c of+ Accept s -> addHistory hstName s >> return s+ Cancel -> return ""+ Continue s buf -> go s buf++-- | Read a line of user input.+getInputLine_ :: MonadIO m => Window -> String -> HistoryNamespace -> CompletionFunction -> InputT m String+getInputLine_ = getInputLine (const $ return ())++-- | Read a line of user input.+--+-- Apply given action on each keystroke to intermediate result.+getInputLine :: MonadIO m => (String -> m ()) -> Window -> String -> HistoryNamespace -> CompletionFunction -> InputT m String+getInputLine action window prompt hstName complete = do+ r <- readline complete hstName update+ liftIO (Curses.werase window)+ return r+ where+ update r@(_, input, _) = InputT . lift $ do+ action input+ liftIO (updateWindow window prompt r)++-- | Draw intermediate result to screen.+updateWindow :: Window -> String -> IntermediateResult -> IO ()+updateWindow window prompt (cursor, input, suggestions) = do+ Curses.werase window++ let s = intercalate " " suggestions++ -- It is important to draw everything with one single call to mvwaddstr!+ --+ -- Otherwise subsequent calls to mvwaddstr overwrite the the last column, if+ -- the start position is outside the window.+ Curses.mvwaddstr window 0 0 (prompt ++ input ++ replicate 6 ' ' ++ s)++ mvwchgat window 0 (length prompt + cursor) 1 [Reverse] InputColor++ -- color suggestions+ unless (null s) $ do+ let start = length prompt + length input + 6+ mvwchgat window 0 start (length s) [] SuggestionsColor++ return ()
+ src/Key.hs view
@@ -0,0 +1,212 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Key (+ keyNames+, ExpandKeyError (..)+, expandKeys+, unExpandKeys+, keyEsc+, keyTab+, ctrlA+, ctrlB+, ctrlC+, ctrlD+, ctrlE+, ctrlF+, ctrlG+, ctrlH+, ctrlI+, ctrlJ+, ctrlK+, ctrlL+, ctrlM+, ctrlN+, ctrlO+, ctrlP+, ctrlQ+, ctrlR+, ctrlS+, ctrlT+, ctrlU+, ctrlV+, ctrlW+, ctrlX+, ctrlY+, ctrlZ+) where++import Data.Tuple (swap)+import Data.Char (toLower)++import Data.Maybe (fromMaybe)++import Data.Map (Map)+import qualified Data.Map as Map++import UI.Curses.Key+++keyEsc = '\ESC'+keyTab = '\t'++ctrlA = '\SOH'+ctrlB = '\STX'+ctrlC = '\ETX'+ctrlD = '\EOT'+ctrlE = '\ENQ'+ctrlF = '\ACK'+ctrlG = '\BEL'+ctrlH = '\BS'+ctrlI = '\HT'+ctrlJ = '\LF'+ctrlK = '\VT'+ctrlL = '\FF'+ctrlM = '\CR'+ctrlN = '\SO'+ctrlO = '\SI'+ctrlP = '\DLE'+ctrlQ = '\DC1'+ctrlR = '\DC2'+ctrlS = '\DC3'+ctrlT = '\DC4'+ctrlU = '\NAK'+ctrlV = '\SYN'+ctrlW = '\ETB'+ctrlX = '\CAN'+ctrlY = '\EM'+ctrlZ = '\SUB'+++-- | Associate each key with Vim's key-notation.+keys :: [(Char, String)]+keys = [+ m keyEsc "Esc"+ , m keyTab "Tab"++ , m ctrlA "C-A"+ , m ctrlB "C-B"+ , m ctrlC "C-C"+ , m ctrlD "C-D"+ , m ctrlE "C-E"+ , m ctrlF "C-F"+ , m ctrlG "C-G"+ , m ctrlH "C-H"+ , m ctrlI "C-I"+ , m ctrlJ "C-J"+ , m ctrlK "C-K"+ , m ctrlL "C-L"+ , m ctrlM "C-M"+ , m ctrlN "C-N"+ , m ctrlO "C-O"+ , m ctrlP "C-P"+ , m ctrlQ "C-Q"+ , m ctrlR "C-R"+ , m ctrlS "C-S"+ , m ctrlT "C-T"+ , m ctrlU "C-U"+ , m ctrlV "C-V"+ , m ctrlW "C-W"+ , m ctrlX "C-X"+ , m ctrlY "C-Y"+ , m ctrlZ "C-Z"++ -- not defined here+ , m '\n' "CR"+ , m ' ' "Space"++ , m keyUp "Up"+ , m keyDown "Down"+ , m keyLeft "Left"+ , m keyRight "Right"++ , m keyPpage "PageUp"+ , m keyNpage "PageDown"+ ]+ where+ m = (,)++keyNames :: [String]+keyNames = map snd keys+++-- | A mapping from spcial keys to Vim's key-notation.+--+-- The brackets are included.+keyMap :: Map Char String+keyMap = Map.fromList (map (fmap (\s -> "<" ++ s ++ ">")) keys)+++-- | A mapping from Vim's key-notation to their corresponding keys.+--+-- The brackets are not included, and only lower-case is used for key-notation.+keyNotationMap :: Map String Char+keyNotationMap = Map.fromList (map (swap . fmap (map toLower)) keys)+++-- | Replace all special keys with their corresponding key reference.+--+-- Vim's key-notation is used for key references.+unExpandKeys = foldr f ""+ where+ f c+ -- escape opening brackets..+ | c == '<' = ("\\<" ++)++ -- escape backslashes+ | c == '\\' = ("\\\\" ++)++ | otherwise = (keyNotation c ++)++ -- | Convert given character to Vim's key-notation.+ keyNotation c = fromMaybe (return c) (Map.lookup c keyMap)++data ExpandKeyError =+ EmptyKeyReference+ | UnterminatedKeyReference String+ | UnknownKeyReference String+ deriving Eq++instance Show ExpandKeyError where+ show e = case e of+ EmptyKeyReference -> "empty key reference"+ UnterminatedKeyReference k -> "unterminated key reference " ++ show k+ UnknownKeyReference k -> "unknown key reference " ++ show k++-- | Expand all key references to their corresponding keys.+--+-- Vim's key-notation is used for key references.+expandKeys :: String -> Either ExpandKeyError String+expandKeys = go+ where+ go s = case s of+ "" -> return ""++ -- keep escaped characters+ '\\':x:xs -> x `cons` go xs++ -- expand key references+ '<' : xs -> expand xs++ -- keep any other characters+ x:xs -> x `cons` go xs++ -- | Prepend given element to a list in the either monad.+ cons :: b -> Either a [b] -> Either a [b]+ cons = fmap . (:)++ -- Assume that `xs` starts with a key reference, terminated with a closing+ -- bracket. Replace that key reference with it's corresponding key.+ expand xs = do+ (k, ys) <- takeKeyReference xs+ case Map.lookup k keyNotationMap of+ Just x -> (x :) `fmap` go ys+ Nothing -> Left (UnknownKeyReference k)++ -- Assume that `s` starts with a key reference, terminated with a closing+ -- bracket. Return the key reference (converted to lower-case) and the+ -- suffix, drop the closing bracket.+ takeKeyReference :: String -> Either ExpandKeyError (String, String)+ takeKeyReference s = case break (== '>') s of+ (xs, "") -> Left (UnterminatedKeyReference xs)+ ("", _ ) -> Left EmptyKeyReference+ (xs, '>':ys) -> return (map toLower xs, ys)+ _ -> error "Key.takeKeyReference: this should never happen"
+ src/Macro.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-}+module Macro (+ Macros+, addMacro+, removeMacro+, expandMacro+, help+, helpAll+, guessCommands+) where++import Prelude hiding (getChar)+import Data.List (isPrefixOf)+import Text.Printf (printf)++import Data.Map (Map)+import qualified Data.Map as Map++import Data.Default++import Key (unExpandKeys)++import Input++newtype Macros = Macros (Map String String)++-- helper for `help` and `helpAll`+formatMacro :: String -> String -> String+formatMacro m c = printf "%-10s %s" (unExpandKeys m) (unExpandKeys c)++-- | Get help message for a macro.+help :: String -> Macros -> Either String String+help m (Macros ms) = maybe (noMapping m) (Right . formatMacro m) (Map.lookup m ms)++-- | Convert macros to a list of strings, suitable for help.+helpAll :: Macros -> [String]+helpAll (Macros ms) = map (uncurry formatMacro) (Map.toList ms)++noMapping :: String -> Either String a+noMapping m = Left ("no mapping for " ++ unExpandKeys m)++-- | Expand a macro.+expandMacro :: Monad m => Macros -> Char -> InputT m ()+expandMacro (Macros macroMap) = go . return+ where+ keys = Map.keys macroMap++ go input = do+ case Map.lookup input macroMap of+ Just v -> unGetString v+ Nothing ->+ if null matches+ then do+ -- input does not match any macro, so we consume exactly one+ -- character and push the rest back into the input queue+ unGetString (tail input)+ else do+ -- input is a prefix of some macro, so we read an other character+ c <- getChar+ go (input ++ [c])+ where+ matches = filter (isPrefixOf input) keys++-- | Add a macro.+addMacro :: String -> String -> Macros -> Macros+addMacro m e (Macros ms) = Macros (Map.insert m e ms)++-- | Remove a macro.+removeMacro :: String -> Macros -> Either String Macros+removeMacro m (Macros ms)+ | m `Map.member` ms = (Right . Macros . Map.delete m) ms+ | otherwise = noMapping m++-- | Construct a map from command to macros defined for that command.+guessCommands :: [String] -> Macros -> Map String [String]+guessCommands commands (Macros ms) = (Map.fromListWith (++) . foldr f [] . Map.toDescList) ms+ where+ f (m, e) xs+ | c `elem` commands = (c, [unExpandKeys m]) : xs+ | otherwise = xs+ where c = strip e++ strip xs+ | ':':ys <- xs, '\n':zs <- reverse ys = reverse zs+ | otherwise = xs++-- | Default macros.+instance Default Macros where+ def = Macros Map.empty
+ src/Option.hs view
@@ -0,0 +1,70 @@+module Option (getOptions) where++import Data.Maybe+import Data.List+import Control.Monad+import Text.Printf (printf)+import System.Environment (getArgs, getProgName)+import System.Exit (exitSuccess, exitFailure)+import System.IO (hPutStr, stderr)+import System.Console.GetOpt++data Option = Help+ | IgnoreVimusrc+ | OptionHost String+ | OptionPort String+ deriving (Show, Eq)++hostHelp :: String+hostHelp = intercalate "\n"+ [ "The host to connect to; if not given, the value"+ , "of the environment variable MPD_HOST is checked"+ , "before defaulting to localhost. To use a"+ , "password, provide a value of the form"+ , "`password@host'."+ ]++portHelp :: String+portHelp = intercalate "\n"+ [ "The port to connect to; if not given, the value"+ , "of the environment variable MPD_PORT is checked"+ , "before defaulting to 6600."+ ]++options :: [OptDescr Option]+options = [+ Option [] ["help"] (NoArg Help ) "Display this help and exit."+ , Option ['h'] ["host"] (ReqArg OptionHost "HOST") hostHelp+ , Option ['p'] ["port"] (ReqArg OptionPort "PORT") portHelp+ , Option [] ["ignore-vimusrc"] (NoArg IgnoreVimusrc ) "Do not source ~/.vimusrc on startup."+ ]+++getOptions :: IO (Maybe String, Maybe String, Bool)+getOptions = do++ (opts, args, errors) <- getOpt Permute options `liftM` getArgs++ when (Help `elem` opts) $ do+ progName <- getProgName+ putStr $ usageInfo (printf "Usage: %s [options]\n\nOPTIONS" progName) options+ exitSuccess++ unless (null errors) $+ exitTryHelp $ head errors++ unless (null args) $+ exitTryHelp $ printf "unexpected argument `%s'\n" $ head args++ let port = listToMaybe . reverse $ [ option | OptionPort option <- opts ]+ let host = listToMaybe . reverse $ [ option | OptionHost option <- opts ]+ let ignoreVimusrc = IgnoreVimusrc `elem` opts++ return (host, port, ignoreVimusrc)+++exitTryHelp :: String -> IO a+exitTryHelp message = do+ progName <- getProgName+ hPutStr stderr $ printf "%s: %sTry `%s --help' for more information.\n" progName message progName+ exitFailure
+ src/PlaybackState.hs view
@@ -0,0 +1,95 @@+module PlaybackState (+ onChange+, elapsedTime+) where++import Prelude hiding (mapM_)+import Data.Foldable (mapM_)++import Control.Monad (when, forever)+import Control.Applicative+import Control.Monad.State.Strict (liftIO, evalStateT, gets, modify)++import Data.Default++import Data.Maybe (fromMaybe)++import qualified Network.MPD as MPD hiding (withMPD)+import Network.MPD (MPD(), Seconds, Song)+import qualified Network.MPD.Applicative as MPDA++import Timer++import Type ()++data State = State {+ timer :: Maybe Timer+, currentSong :: Maybe Song+}++instance Default State where+ def = State def def++elapsedTime :: MPD.Status -> (Seconds, Seconds)+elapsedTime s = case MPD.stTime s of Just (c, t) -> (truncate c, t); _ -> (0, 0)++-- | Execute given actions on changes.+onChange :: IO () -> (Maybe Song -> IO ()) -> (Maybe Song -> MPD.Status -> IO ()) -> MPD ()+onChange plChanged songChanged statusChanged =+ evalStateT (updatePlaylist >> updateTimerAndCurrentSong >> idle) def+ where++ -- Wait for changes.+ idle = forever $ do+ r <- MPD.idle [MPD.PlaylistS, MPD.PlayerS, MPD.OptionsS, MPD.UpdateS, MPD.MixerS]+ if (MPD.PlaylistS `elem` r)+ then do+ -- If the playlist changed, we have to run both, `updatePlaylist` and+ -- `updateTimerAndCurrentSong`.+ --+ -- `updateTimerAndCurrentSong` is necessary to emit+ -- EvCurrentSongChanged. This is necessary even if the song did not+ -- really change, because it's position within the playlist may have+ -- changed; and we only use a position to mark the current element of+ -- a ListWidget (say the currently played song here).+ updatePlaylist+ updateTimerAndCurrentSong+ else do+ -- MPD.PlayerS | MPD.OptionsS | MPD.UpdateS | MPD.MixerS+ updateTimerAndCurrentSong++ -- Call `plChanged` action.+ updatePlaylist = liftIO plChanged++ -- Query MPD's status and call `statusChanged`, and if current song changed+ -- `songChanged`. If a song is currently being played, start a timer, that+ -- repeatedly updates the elapsed time and calls `statusChanged`.+ updateTimerAndCurrentSong = do++ -- stop old timer (if any)+ gets timer >>= mapM_ (liftIO . stopTimer)+ modify (\st -> st {timer = Nothing})++ -- query status and call `statusChanged`+ (song, status) <- MPDA.runCommand $ (,) <$> MPDA.currentSong <*> MPDA.status+ liftIO (statusChanged song status)++ -- call `songChanged` if necessary+ oldSong <- gets currentSong+ when (oldSong /= song) $ do+ modify (\st -> st {currentSong = song})+ liftIO (songChanged song)++ -- start timer, if playing+ when (MPD.stState status == MPD.Playing) $ do+ t0 <- liftIO getPOSIXTime+ let (s0, _) = fromMaybe (0, 0) (MPD.stTime status)+ t <- liftIO . startTimer t0 s0 $ \elapsed -> do+ statusChanged song (updateElapsedTime status elapsed)+ modify (\st -> st {timer = Just t})++-- | Set elapsed time of given status to given seconds.+updateElapsedTime :: MPD.Status -> Double -> MPD.Status+updateElapsedTime st seconds = st {MPD.stTime = Just (seconds, timeTotal)}+ where+ (_, timeTotal) = fromMaybe (0, 0) (MPD.stTime st)
+ src/Queue.hs view
@@ -0,0 +1,27 @@+-- | A simple unbounded queue.+--+-- All operations are non-blocking.+module Queue (+ Queue+, newQueue+, putQueue+, takeAllQueue+) where++import Control.Exception (mask_)+import Control.Concurrent.MVar+import Control.Applicative++newtype Queue a = Queue (MVar [a])++-- | Create an empty queue.+newQueue :: IO (Queue a)+newQueue = Queue <$> newMVar []++-- | Put an element into the queue.+putQueue :: Queue a -> a -> IO ()+putQueue (Queue m) x = mask_ $ takeMVar m >>= putMVar m . (x:)++-- | Take all elements from the queue.+takeAllQueue :: Queue a -> IO [a]+takeAllQueue (Queue m) = reverse <$> swapMVar m []
+ src/Render.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Render (+ Render+, runRender+, getWindowSize+, addstr+, addLine+, chgat+, withColor++-- * exported to silence warnings+, Environment (..)++-- * exported for testing+, fitToColumn+) where++import Control.Applicative+import Control.Monad.Reader+import UI.Curses hiding (wgetch, ungetch, mvaddstr, err, mvwchgat, addstr, wcolor_set)+import Data.Char.WCWidth++import Widget.Type+import WindowLayout++data Environment = Environment {+ environmentWindow :: Window+, environmentOffsetY :: Int+, environmentOffsetX :: Int+, environmentSize :: WindowSize+}++newtype Render a = Render (ReaderT Environment IO a)+ deriving (Functor, Monad, Applicative)++runRender :: Window -> Int -> Int -> WindowSize -> Render a -> IO a+runRender window y x ws (Render action) = runReaderT action (Environment window y x ws)++getWindowSize :: Render WindowSize+getWindowSize = Render (asks environmentSize)++-- | Translate given coordinates and run given action+--+-- The action is only run, if coordinates are within the drawing area.+withTranslated :: Int -> Int -> (Window -> Int -> Int -> Int -> IO a) -> Render ()+withTranslated y_ x_ action = Render $ do+ r <- ask+ case r of+ Environment window offsetY offsetX (WindowSize sizeY sizeX)+ | 0 <= x && x < (sizeX + offsetX)+ && 0 <= y && y < (sizeY + offsetY) -> liftIO $ void (action window y x n)+ | otherwise -> return ()+ where+ x = x_ + offsetX+ y = y_ + offsetY+ n = sizeX - x++addstr :: Int -> Int -> String -> Render ()+addstr y_ x_ str = withTranslated y_ x_ $ \window y x n ->+ mvwaddnwstr window y x str (fitToColumn str n)++-- |+-- Determine how many characters from a given string fit in a column of a given+-- width.+fitToColumn :: String -> Int -> Int+fitToColumn str maxWidth = go str 0 0+ where+ go [] _ n = n+ go (x:xs) width n+ | width_ <= maxWidth = go xs width_ (succ n)+ | otherwise = n+ where+ width_ = width + wcwidth x++addLine :: Int -> Int -> TextLine -> Render ()+addLine y_ x_ (TextLine xs) = go y_ x_ xs+ where+ go y x chunks = case chunks of+ [] -> return ()+ c:cs -> case c of+ Plain s -> addstr y x s >> go y (x + length s) cs+ Colored color s -> withColor color (addstr y x s) >> go y (x + length s) cs++chgat :: Int -> [Attribute] -> WindowColor -> Render ()+chgat y_ attr wc = withTranslated y_ 0 $ \window y x n ->+ mvwchgat window y x n attr wc++withColor :: WindowColor -> Render a -> Render a+withColor color action = do+ window <- Render $ asks environmentWindow+ setColor window color *> action <* setColor window MainColor+ where+ setColor w c = Render . liftIO $ wcolor_set w c
+ src/Ruler.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Ruler where++import Text.Printf (printf)++import WindowLayout+import Render+import Widget.Type++type PositionIndicator = Maybe (Int, Int)++data Ruler = Ruler String PositionIndicator Visible+ deriving (Eq, Show)++-- | A vim-like "visible" indicator.+data Visible = All | Top | Bot | Percent Int+ deriving Eq++instance Show Visible where+ show v = case v of+ All -> "All"+ Top -> "Top"+ Bot -> "Bot"+ Percent n -> printf "%2d%%" n++-- | Calculate a vim-like "visible" indicator.+visible :: Int -> Int -> Int -> Visible+visible size viewSize pos+ | topVisible && botVisible = All+ | topVisible = Top+ | botVisible = Bot+ | otherwise = Percent $ (pos * 100) `div` (size - viewSize)+ where+ topVisible = pos == 0+ botVisible = size <= pos + viewSize++-- | Render ruler.+drawRuler :: Ruler -> Render ()+drawRuler (Ruler text positionIndicator visibleIndicator) = do+ WindowSize _ sizeX <- getWindowSize+ let addstr_end str = addstr 0 x str+ where x = max 0 (sizeX - length str)+ addstr 0 0 text+ addstr_end $ maybe "" (uncurry $ printf "%6d/%-6d ") positionIndicator ++ show visibleIndicator+ chgat 0 [] RulerColor
+ src/Run.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Run (main) where++import Prelude hiding (getChar)+import UI.Curses hiding (err, wgetch, wget_wch, ungetch, mvaddstr)+import qualified UI.Curses as Curses+import Control.Exception (finally)+import Data.Maybe++import qualified Network.MPD as MPD hiding (withMPD)+import Network.MPD (Seconds, MonadMPD)++import Control.Monad.State.Strict (unless, lift, liftIO, forever, MonadIO)+import Data.Foldable (forM_)+import Data.List hiding (filter)+import Data.IORef+import System.Directory (doesFileExist)+import Control.Concurrent (forkIO)+import Text.Printf (printf)++import qualified WindowLayout+import qualified Input+import Input (HistoryNamespace(..), noCompletion)+import Macro+import qualified PlaybackState+import Option (getOptions)+import Util (expandHome)+import Queue+import Vimus+import qualified Command as Command+import qualified Song++------------------------------------------------------------------------+-- The main event loop+--+mainLoop :: Window -> Queue Notify -> IO Window -> Vimus ()+mainLoop window queue onResize = Input.runInputT wget_wch . forever $ do+ c <- Input.getChar+ case c of+ -- a command+ ':' -> do+ input <- Input.getInputLine_ window ":" CommandHistory Command.autoComplete+ unless (null input) $ lift $ do+ Command.runCommand input+ renderMainWindow++ -- search+ '/' -> do+ input <- Input.getInputLine searchPreview window "/" SearchHistory noCompletion+ unless (null input) $ lift $ do+ search input++ -- window has to be redrawn, even if input is Nothing, otherwise the+ -- preview will remain on the screen+ lift renderMainWindow++ -- filter+ 'F' -> do+ widget <- lift getCurrentWidget+ cache <- liftIO $ newIORef []+ input <- Input.getInputLine (filterPreview widget cache) window "filter: " SearchHistory noCompletion+ unless (null input) $ lift $ do+ filter_ input++ -- window has to be redrawn, even if input is Nothing, otherwise the+ -- preview will remain on the screen+ lift renderMainWindow++ -- macro expansion+ _ -> do+ macros <- lift getMacros+ expandMacro macros c+ where+ searchPreview term = do+ widget <- getCurrentWidget+ renderToMainWindow (searchItem widget Forward term)++ filterPreview :: AnyWidget -> IORef [(String, AnyWidget)] -> String -> Vimus ()+ filterPreview widget cache term = do+ w <- liftIO $ do+ modifyIORef cache updateCache+ -- cache now contains results for all `inits term', in reverse order+ r <- readIORef cache+ (return . snd . head) r+ renderToMainWindow w+ where+ updateCache :: [(String, AnyWidget)] -> [(String, AnyWidget)]+ updateCache old@((t, w):xs)+ | term == t = old+ | t `isPrefixOf` term = (term, filterItem w term) : old+ | otherwise = updateCache xs+ -- applying filterItem to widget even if term is "" is crucial,+ -- otherwise the position won't be set to 0+ updateCache [] = [(term, filterItem widget term)]++ -- |+ -- A wrapper for wget_wch, that keeps the event queue running and handles+ -- resize events.+ wget_wch = do+ handleNotifies queue+ c <- liftIO (Curses.wget_wch window)+ continue c+ where+ resize = liftIO onResize >>= setMainWindow+ continue c+ | c == '\0' = wget_wch+ | c == keyResize = resize >> wget_wch+ | otherwise = return c+++data Notify = NotifyEvent Event+ | NotifyError String+ | NotifyAction (Vimus ())+++handleNotifies :: Queue Notify -> Vimus ()+handleNotifies q = do+ xs <- liftIO (takeAllQueue q)+ forM_ xs $ \x -> case x of+ NotifyEvent event -> sendEvent event >> renderMainWindow+ NotifyError err -> error err+ NotifyAction action -> action+++------------------------------------------------------------------------+-- mpd status++updateStatus :: (MonadIO m) => Window -> Window -> Maybe MPD.Song -> MPD.Status -> m ()+updateStatus songWindow playWindow mSong status = do++ putString songWindow song ""+ putString playWindow playState tags+ where+ song = fromMaybe "none" (Song.title =<< mSong)++ playState = stateSymbol ++ " " ++ formatTime current ++ " / " ++ formatTime total+ ++ volume+ where+ (current, total) = PlaybackState.elapsedTime status+ stateSymbol = case MPD.stState status of+ MPD.Playing -> "|>"+ MPD.Paused -> "||"+ MPD.Stopped -> "[]"++ volume = maybe "" ((" vol: " ++) . show) (MPD.stVolume status)++ tags = intercalate ", " . map snd . filter (($ status) . fst) $ tagList++ tagList :: [(MPD.Status -> Bool, String)]+ tagList = [+ (isJust . MPD.stUpdatingDb, "updating")+ , (MPD.stRepeat , "repeat")+ , (MPD.stRandom , "random")+ , (MPD.stSingle , "single")+ , (MPD.stConsume , "consume")+ ]++ formatTime :: Seconds -> String+ formatTime s = printf "%02d:%02d" minutes seconds+ where+ (minutes, seconds) = s `divMod` 60++ putString :: (MonadIO m) => Window -> String -> String -> m ()+ putString window string endstring = liftIO $ do+ (_, sizeX) <- getmaxyx window+ mvwaddstr window 0 0 string+ wclrtoeol window+ mvwaddstr window 0 (sizeX - length endstring) endstring+ wrefresh window+ return ()+++------------------------------------------------------------------------+-- Tabs++notifyEvent :: MonadIO m => Queue Notify -> Event -> m ()+notifyEvent q e = liftIO $ q `putQueue` NotifyEvent e++notifyLibraryChanged :: (MonadIO m, MonadMPD m) => Queue Notify -> m ()+notifyLibraryChanged q = MPD.listAllInfo "" >>= notifyEvent q . EvLibraryChanged++------------------------------------------------------------------------+-- Program entry point++run :: Maybe String -> Maybe String -> Bool -> IO ()+run host port ignoreVimusrc = do++ (onResize, tw, mw, songStatusWindow, playStatusWindow, inputWindow) <- WindowLayout.create++ let initialize = do++ -- load default mappings+ Command.runCommand "runtime default-mappings"++ -- source ~/.vimusrc+ r <- liftIO (expandHome "~/.vimusrc")+ flip (either printError) r $ \vimusrc -> do+ exists <- liftIO (doesFileExist vimusrc)+ if not ignoreVimusrc && exists+ then+ Command.source vimusrc+ else liftIO $ do+ -- only print this if .vimusrc does not exist, otherwise it would+ -- overwrite possible config errors+ mvwaddstr inputWindow 0 0 "type :quit to exit, :help for help"+ return ()++ liftIO $ do+ -- It is critical, that this is only done after sourcing .vimusrc,+ -- otherwise :color commands are not effective and the user will see an+ -- annoying flicker!+ wrefresh inputWindow+ wrefresh songStatusWindow+ wrefresh playStatusWindow++ renderTabBar+ renderMainWindow++ return ()++ queue <- newQueue+ let withMPD_notifyError = withMPD (putQueue queue . NotifyError)++ -- watch for playback and playlist changes+ forkIO $ withMPD_notifyError $ PlaybackState.onChange+ (notifyEvent queue EvPlaylistChanged)+ (notifyEvent queue . EvCurrentSongChanged)+ (\song -> putQueue queue . NotifyAction . updateStatus songStatusWindow playStatusWindow song)++ -- watch for library updates+ forkIO $ withMPD_notifyError $ do+ notifyLibraryChanged queue+ forever (MPD.idle [MPD.DatabaseS] >> notifyLibraryChanged queue)+++ -- We use a timeout of 10 ms, but be aware that the actual timeout may be+ -- different due to a combination of two facts:+ --+ -- (1) ncurses getch (and related functions) returns when a signal occurs+ -- (2) the threaded GHC runtime uses signals for bookkeeping+ -- (see +RTS -V option)+ --+ -- So the effective timeout is swayed by the runtime.+ --+ -- We may workaround this in the future, as suggest here:+ -- http://www.serpentine.com/blog/2010/09/04/dealing-with-fragile-c-libraries-e-g-mysql-from-haskell/+ wtimeout inputWindow 10++ keypad inputWindow True++ withMPD error $ runVimus Command.tabs mw inputWindow tw (initialize >> mainLoop inputWindow queue onResize)+ where+ withMPD onError action = do+ result <- MPD.withMPD_ host port action+ case result of+ Left e -> onError (show e)+ Right () -> return ()+++main :: IO ()+main = do++ (host, port, ignoreVimusrc) <- getOptions++ -- recommended in ncurses manpage+ initscr+ raw+ noecho++ -- suggested in ncurses manpage+ -- nonl+ intrflush stdscr True++ -- enable colors+ use_default_colors+ start_color++ curs_set 0++ finally (run host port ignoreVimusrc) endwin
+ src/Song.hs view
@@ -0,0 +1,74 @@+-- | Songs metadata+module Song (+ metaQueries+, album+, artist+, title+, track+) where++import Data.List (intercalate)+import Data.Map (Map)+import qualified Data.Map as Map+import Prelude hiding (length)+import qualified System.FilePath as FilePath+import Text.Printf (printf)++import qualified Network.MPD as MPD hiding (withMPD)++++type MetaQuery = MPD.Song -> Maybe String++metaQueries :: Map String MetaQuery+metaQueries = Map.fromList+ [ ("artist" , artist)+ , ("album" , album)+ , ("title" , title)+ , ("track" , track)+ , ("genre" , genre)+ , ("year" , year)+ , ("composer" , composer)+ , ("performer" , performer)+ , ("comment" , comment)+ , ("disc" , disc)+ , ("length" , length)+ , ("filename" , filename)+ , ("directory" , directory)+ ]++-- | Song tags queries+artist, album, title, track, genre, year, composer, performer, comment, disc :: MetaQuery+[artist, album, title, genre, year, composer, performer, comment, disc] =+ map lookupMetadata+ [ MPD.Artist+ , MPD.Album+ , MPD.Title+ , MPD.Genre+ , MPD.Date+ , MPD.Composer+ , MPD.Performer+ , MPD.Comment+ , MPD.Disc+ ]++track = fmap (printf "%02s") . lookupMetadata MPD.Track++-- | Get comma-separated list of meta data+lookupMetadata :: MPD.Metadata -> MetaQuery+lookupMetadata key song = case Map.lookup key tags of+ Nothing -> Nothing+ Just xs -> Just $ intercalate ", " (map MPD.toString xs)+ where+ tags = MPD.sgTags song+++-- | Song file queries+length, filename, directory :: MetaQuery+length s =+ let (minutes, seconds) = MPD.sgLength s `divMod` 60+ in Just $ printf "%d:%02d" minutes seconds++filename = Just . FilePath.takeFileName . MPD.toString . MPD.sgFilePath++directory = Just . FilePath.takeDirectory . MPD.toString . MPD.sgFilePath
+ src/Song/Format.hs view
@@ -0,0 +1,131 @@+-- | Song format parser+module Song.Format (+ SongFormat(..)+, parser++-- * exported for testing+, FormatTree(..)+, format+, meta+, alternatives+, parse+) where++import Control.Applicative (Alternative(..), pure, liftA2)+import Data.Default (Default(..))+import Data.Foldable (asum)+import Data.List (intercalate)+import Data.Maybe (fromMaybe)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid (Monoid(..))+import Text.Printf (printf)++import qualified Network.MPD as MPD++import qualified Command.Parser as Parser++import Song+++infixr 4 :+:++-- | AST for formats:+data FormatTree s m a =+ Empty+ | Pure a+ | FormatTree s m a :+: FormatTree s m a+ | Meta (s -> m a)+ | Alt [FormatTree s m a]++-- | Format AST+format+ :: (Alternative m, Monoid a)+ => a -- ^ default value for failed top-level metadata query+ -> s -- ^ container for metadata+ -> FormatTree s m a -> m a+format d n = top where+ top Empty = empty+ top (Pure a) = pure a+ top (x :+: y) = top x <#> top y+ top (Alt xs) = asum $ fmap nested xs+ top (Meta f) = f n <|> pure d -- if metadata query failed, replace failure with 'd'++ nested (Meta f) = f n+ nested (x :+: y) = nested x <#> nested y+ nested t = top t++ (<#>) = liftA2 mappend+++newtype SongFormat = SongFormat (MPD.Song -> String)++instance Default SongFormat where+ def = SongFormat $ \song ->+ printf "%s - %s - %s - %s"+ (orNone $ artist song)+ (orNone $ album song)+ (orNone $ track song)+ (orNone $ title song)+ where+ orNone = fromMaybe "(none)"++parser :: Map String (MPD.Song -> Maybe String) -> Parser.Parser SongFormat+parser queries = Parser.Parser $ \str -> do+ tree <- parse queries str+ return (SongFormat (\song -> fromMaybe "(none)" $ format "none" song tree), "")++parse+ :: Map String (MPD.Song -> Maybe String)+ -> String+ -> Either Parser.ParseError (FormatTree MPD.Song Maybe String)+parse queries = go "" where+ go acc ('\\':'(':cs) = go ('(':acc) cs+ go acc ('\\':')':cs) = go (')':acc) cs+ go acc ('\\':'%':cs) = go ('%':acc) cs+ go acc ('(':cs) = do+ (xs, ys) <- alternatives cs+ alts <- mapM (go "") xs+ rest <- go "" ys+ return $ Pure (reverse acc) <+> Alt alts <+> rest+ go acc ('%':cs) = do+ (key, ys) <- meta cs+ case Map.lookup key queries of+ Nothing -> Left (Parser.ParseError $ "non-supported meta pattern: %" ++ key ++ "%")+ Just metadata -> do+ rest <- go "" ys+ return $ Pure (reverse acc) <+> Meta metadata <+> rest+ go acc (c:cs) = go (c:acc) cs+ go acc [] = Right (Pure (reverse acc))++ infixr 4 <+>+ Pure "" <+> x = x+ x <+> Pure "" = x+ x <+> y = x :+: y+++data Nat = Z | S Nat++-- | Parse alternatives pattern+alternatives :: String -> Either Parser.ParseError ([String], String)+alternatives = go Z [] "" where+ go n strings acc ('\\':'(':xs) = go n strings ('(':'\\':acc) xs+ go n strings acc ('\\':')':xs) = go n strings (')':'\\':acc) xs+ go n strings acc ('\\':'|':xs) = go n strings ('|':'\\':acc) xs+ go n strings acc ('(':xs) = go (S n) strings ('(':acc) xs+ go Z strings acc (')':xs) = Right (reverse (reverse acc : strings), xs)+ go (S n) strings acc (')':xs) = go n strings (')':acc) xs+ go Z strings acc ('|':xs) = go Z (reverse acc : strings) [] xs+ go n strings acc (x:xs) = go n strings (x:acc) xs+ go _ strings acc [] = Left . Parser.ParseError $+ "unterminated alternatives pattern: (" ++ intercalate "|" (reverse acc : strings)++-- | Parse meta pattern+meta :: String -> Either Parser.ParseError (String, String)+meta = go "" where+ go acc ('\\':'%':xs) = go ('%':acc) xs+ go acc ('%':xs) = Right (reverse acc, xs)+ go acc (x:xs) = go (x:acc) xs+ go acc [] = Left (Parser.ParseError $ "unterminated meta pattern: %" ++ reverse acc)++
+ src/Tab.hs view
@@ -0,0 +1,146 @@+module Tab (+ Tab (..)+, TabName (..)+, CloseMode (..)+, isAutoClose++, Tabs (..) -- constructors exported for testing++, fromList+, toList+, preCurSuf++, previous+, next+, select++, current+, modify+, insert+, close+) where++import Prelude hiding (foldl, foldr)+import Data.List (foldl')+import Control.Applicative+import Data.Traversable (Traversable(..))+import Data.Foldable (Foldable(foldr))++-- | Tab zipper+data Tabs a = Tabs ![Tab a] !(Tab a) ![Tab a]++data CloseMode =+ Persistent -- ^ tab can not be closed+ | Closeable -- ^ tab can be closed+ | AutoClose -- ^ tab is automatically closed on unfocus+ deriving (Eq, Ord, Show)++-- | True, if tab is automatically closed on unfocus.+isAutoClose :: Tab a -> Bool+isAutoClose = (== AutoClose) . tabCloseMode++-- | True, if tab can be closed.+isCloseable :: Tab a -> Bool+isCloseable = (/= Persistent) . tabCloseMode++data Tab a = Tab {+ tabName :: !TabName+, tabContent :: !a+, tabCloseMode :: !CloseMode+}++instance Functor Tab where+ fmap f (Tab n c a) = Tab n (f c) a++instance Functor Tabs where+ fmap g (Tabs xs c ys) = Tabs (map f xs) (f c) (map f ys)+ where f = fmap g++instance Foldable Tabs where+ foldr g z (Tabs xs y ys) = foldl' (flip f) (foldr f z (y:ys)) xs+ where f (Tab _ c _) = g c++instance Traversable Tabs where+ traverse g (Tabs xs y ys) = Tabs <$> (reverse <$> traverse f (reverse xs)) <*> f y <*> traverse f ys+ where f (Tab n c a) = flip (Tab n) a <$> g c++data TabName = Playlist | Library | Browser | SearchResult | Other String+ deriving Eq++instance Show TabName where+ show name = case name of+ Playlist -> "Playlist"+ Library -> "Library"+ Browser -> "Browser"+ SearchResult -> "SearchResult"+ Other s -> s++fromList :: [Tab a] -> Tabs a+fromList (c:ys) = Tabs [] c ys+fromList [] = error "Tab.fromList: empty list"++toList :: Tabs a -> [Tab a]+toList (Tabs xs c ys) = foldl' (flip (:)) (c:ys) xs++-- | Return prefix, current, and suffix.+preCurSuf :: Tabs a -> ([Tab a], Tab a, [Tab a])+preCurSuf (Tabs pre c suf) = (reverse pre, c, suf)++-- | Move focus to the left.+previous :: Tabs a -> Tabs a+previous (Tabs pre c suf) = case pre of+ x:xs -> Tabs xs x ys+ [] ->+ case reverse ys of+ x:xs -> Tabs xs x []+ [] -> error "Tab.previous: no tabs"+ where ys = if isAutoClose c then suf else c:suf++-- | Move focus to the right.+next :: Tabs a -> Tabs a+next (Tabs pre c suf) = case suf of+ y:ys -> Tabs xs y ys+ [] ->+ case reverse xs of+ y:ys -> Tabs [] y ys+ [] -> error "Tab.next: no tabs"+ where xs = if isAutoClose c then pre else c:pre++-- | Set focus to next tab that matches given predicate.+select :: (Tab a -> Bool) -> Tabs a -> Tabs a+select p tabs@(Tabs pre c suf) =+ case break p suf of+ (ys, z:zs) -> Tabs (xs `combine` ys) z zs+ _ ->+ case break p (reverse xs) of+ (ys, z:zs) -> Tabs (reverse ys) z (zs ++ suf)+ _ -> tabs+ where+ xs = if isAutoClose c then pre else c:pre++ -- | reverse and prepend the second list to the first+ combine = foldl' (flip (:))++-- | Return the focused tab.+current :: Tabs a -> Tab a+current (Tabs _ c _) = c++-- | Close the focused tab, if possible.+close :: Tabs a -> Maybe (Tabs a)+close (Tabs pre c suf)+ | isCloseable c =+ case pre of+ x:xs -> Just (Tabs xs x suf)+ [] -> case reverse suf of+ x:xs -> Just (Tabs xs x pre)+ [] -> Nothing+ | otherwise = Nothing++-- | Modify the focused tab.+modify :: (Tab a -> Tab a) -> Tabs a -> Tabs a+modify f (Tabs xs c ys) = Tabs xs (f c) ys++-- | Insert a new tab after the focused tab; set focus to the new tab.+insert :: Tab a -> Tabs a -> Tabs a+insert x (Tabs pre c ys) = Tabs xs x ys+ where xs = if isAutoClose c then pre else c:pre
+ src/Timer.hs view
@@ -0,0 +1,54 @@+module Timer (+ Timer+, startTimer+, stopTimer+, getPOSIXTime+) where++import Control.Concurrent+import Control.Monad (when)+import Data.Time.Clock.POSIX++newtype Timer = Timer (MVar Bool)++-- | Start a timer.+--+-- Call given action repeatedly with the passed time since the timer has been+-- started, adjusted by a given offset. The action is called every second;+-- whenever (passed + offset) is close to (truncate $ passed + offset).+startTimer :: POSIXTime -- ^ start time+ -> Double -- ^ offset in seconds+ -> (Double -> IO ())+ -> IO Timer+startTimer t0 s0 action = do+ m <- newMVar True+ _ <- forkIO $ run t0 (realToFrac s0) (action . realToFrac) m+ return (Timer m)+++-- | Run until False is put into the MVar.+run :: POSIXTime -> POSIXTime -> (POSIXTime -> IO ()) -> MVar Bool -> IO ()+run t0 s0 action m = go+ where+ go = do+ t1 <- getPOSIXTime+ let s_current = s0 + (t1 - t0)+ -- Increase s_next to the next full second.+ s_next = fromIntegral (ceiling (s_current + 0.001) :: Int)++ sleep (s_next - s_current)+ isRunning <- takeMVar m+ when (isRunning) $ do+ -- add 0.001 as a tiebreaker to make sure that `truncate` will work as+ -- expected+ action (s_next + 0.001)+ putMVar m isRunning+ go++ -- | Like `threadDelay`, but takes the delay in seconds.+ sleep :: POSIXTime -> IO ()+ sleep s = threadDelay $ round (s * 1000000)++-- | Stop timer; block until the timer is stopped.+stopTimer :: Timer -> IO ()+stopTimer (Timer m) = takeMVar m >> putMVar m False
+ src/Type.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | Common types an instances.+module Type where++import Control.Monad.State.Strict+import Network.MPD.Core++instance MonadMPD (StateT a MPD) where+ getVersion = lift getVersion+ open = lift open+ close = lift close+ send = lift . send+ setPassword = lift . setPassword+ getPassword = lift getPassword
+ src/Util.hs view
@@ -0,0 +1,83 @@+module Util where++import Control.Applicative+import Data.List (isPrefixOf)+import Data.Char as Char+import Data.Maybe (fromJust)+import System.FilePath ((</>))+import System.Environment (getEnvironment)++import Network.MPD (MonadMPD, PlaylistName, Id)+import qualified Network.MPD as MPD++-- | Remove leading and trailing whitespace+strip :: String -> String+strip = dropWhile Char.isSpace . reverse . dropWhile Char.isSpace . reverse++data MatchResult = None | Match String | Ambiguous [String]+ deriving (Eq, Show)++match :: String -> [String] -> MatchResult+match s l = case filter (isPrefixOf s) l of+ [] -> None+ [x] -> Match x+ xs -> if s `elem` xs then Match s else Ambiguous xs++-- | Get longest common prefix of a list of strings.+--+-- >>> commonPrefix ["foobar", "foobaz", "foosomething"]+-- "foo"+commonPrefix :: [String] -> String+commonPrefix [] = ""+commonPrefix xs = foldr1 go xs+ where+ go (y:ys) (z:zs)+ | y == z = y : go ys zs+ go _ _ = []++-- | Add a song which is inside a playlist, returning its id.+addPlaylistSong :: MonadMPD m => PlaylistName -> Int -> m Id+addPlaylistSong plist index = do+ current <- MPD.playlistInfo Nothing+ MPD.load plist+ new <- MPD.playlistInfo Nothing++ let (first, this:rest) = splitAt index . map (fromJust . MPD.sgId) $ drop (length current) new+ mapM_ MPD.deleteId $ first ++ rest++ return this++-- | A copy of `System.Process.Internals.translate`.+posixEscape :: String -> String+posixEscape str = '\'' : foldr escape "'" str+ where escape '\'' = showString "'\\''"+ escape c = showChar c+++-- | Expand a tilde at the start of a string to the users home directory.+--+-- Expansion is only performed if the tilde is either followed by a slash or+-- the only character in the string.+expandHome :: FilePath -> IO (Either String FilePath)+expandHome path = do+ home <- maybe err Right . lookup "HOME" <$> getEnvironment+ case path of+ "~" -> return home+ '~' : '/' : xs -> return $ (</> xs) `fmap` home+ xs -> return (Right xs)+ where+ err = Left ("expansion of " ++ show path ++ " failed: $HOME is not defined")++-- | Confine a number to an interval.+--+-- The result will be greater or equal to a given lower bound and (if still+-- possible) smaller than a given upper bound.+clamp :: Int -- ^ lower bound (inclusive)+ -> Int -- ^ upper bound (exclusive)+ -> Int+ -> Int+clamp lower upper n = max lower $ min (pred upper) n++-- | Emit ANSI sequence to change the console window title.+setTitle :: String -> IO ()+setTitle title = putStrLn $ "\ESC]0;" ++ filter (/= '\007') title ++ "\007"
+ src/Vimus.hs view
@@ -0,0 +1,467 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Vimus (+ Vimus+, runVimus++-- * search+, search+, filter_+, searchNext+, searchPrev++-- * macros+, clearMacros+, addMacro+, removeMacro+, getMacros++, TabName (..)+, CloseMode (..)+, Tab (..)+, Event (..)+, sendEvent+, sendEventCurrent+, pageScroll++, Widget (..)+, AnyWidget (..)+, SearchOrder (..)++, printMessage+, printError++, LogMessage+, logMessages++, readCopyRegister+, writeCopyRegister++-- * tabs+, previousTab+, nextTab+, selectTab+, addTab+, closeTab++, getCurrentWidget+, withCurrentSong+, withCurrentItem++, setMainWindow+, renderMainWindow+, renderToMainWindow+, renderTabBar++, getLibraryPath+, setLibraryPath++, setAutoTitle+, getAutoTitle+) where++import Prelude hiding (mapM)+import Data.Functor+import Data.Traversable (mapM)+import Data.Foldable (forM_)+import Control.Monad (join, unless)+import Control.Applicative++import Control.Monad.State.Strict (liftIO, gets, get, put, modify, evalStateT, StateT, MonadState)+import Control.Monad.Trans (MonadIO)++import Data.Default++import Data.Time (formatTime, getZonedTime)+import System.Locale (defaultTimeLocale)++import Network.MPD.Core+import Network.MPD as MPD (LsResult)+import qualified Network.MPD as MPD hiding (withMPD)++import UI.Curses hiding (mvwchgat)++import qualified Macro+import Macro (Macros)++import Content+import Type ()+import Widget.Type++import Tab (Tab(..), TabName(..), CloseMode(..))+import qualified Tab+import WindowLayout (WindowColor(..), mvwchgat)++import Control.Monad.Error.Class+import Util (expandHome)+import Render+import Ruler++import Song.Format (SongFormat)++class Widget a where+ render :: a -> Render Ruler+ currentItem :: a -> Maybe Content+ searchItem :: a -> SearchOrder -> String -> a+ filterItem :: a -> String -> a+ handleEvent :: a -> Event -> Vimus a++data AnyWidget = forall w. Widget w => AnyWidget w++instance Widget AnyWidget where+ render (AnyWidget w) = render w+ currentItem (AnyWidget w) = currentItem w+ searchItem (AnyWidget w) o t = AnyWidget (searchItem w o t)+ filterItem (AnyWidget w) t = AnyWidget (filterItem w t)+ handleEvent (AnyWidget w) e = AnyWidget <$> handleEvent w e++data SearchOrder = Forward | Backward++-- | Events+data Event =+ EvCurrentSongChanged (Maybe MPD.Song)+ | EvPlaylistChanged+ | EvLibraryChanged [LsResult]+ | EvResize WindowSize+ | EvDefaultAction+ | EvMoveUp+ | EvMoveDown+ | EvMoveAlbumPrev+ | EvMoveAlbumNext+ | EvMoveIn+ | EvMoveOut+ | EvMoveFirst+ | EvMoveLast+ | EvScroll Int+ | EvVisual+ | EvNoVisual+ | EvAdd+ | EvInsert Int+ | EvRemove+ | EvCopy+ | EvPaste+ | EvPastePrevious+ | EvLogMessage LogMessage -- ^ emitted when a message is added to the log+ | EvChangeSongFormat SongFormat++-- | Number of lines to scroll on scroll-page-up/scroll-page-down+pageScroll :: Vimus Int+pageScroll = do+ WindowSize sizeY _ <- getMainWidgetSize+ return $ max 0 (sizeY - 2)++-- | Send an event to all widgets.+sendEvent :: Event -> Vimus ()+sendEvent ev = modifyAllWidgets (`handleEvent` ev)++-- | Send an event to current widget.+sendEventCurrent :: Event -> Vimus ()+sendEventCurrent ev = getCurrentWidget >>= (`handleEvent` ev) >>= setCurrentWidget++-- | Search in current widget for given string.+search :: String -> Vimus ()+search term = do+ modify $ \state -> state { getLastSearchTerm = term }+ search_ Forward term++-- | Filter content of current widget.+filter_ :: String -> Vimus ()+filter_ term = do+ tab <- gets (Tab.current . tabView)++ let closeMode = max Closeable (tabCloseMode tab)+ searchResult = filterItem (tabContent tab) term++ case tabName tab of+ SearchResult -> setCurrentWidget searchResult+ _ -> addTab SearchResult searchResult closeMode++-- | Go to next search hit.+searchNext :: Vimus ()+searchNext = do+ state <- get+ search_ Forward $ getLastSearchTerm state++-- | Got to previous search hit.+searchPrev :: Vimus ()+searchPrev = do+ state <- get+ search_ Backward $ getLastSearchTerm state++search_ :: SearchOrder -> String -> Vimus ()+search_ order term = do+ widget <- getCurrentWidget+ setCurrentWidget (searchItem widget order term)++-- * log messages+newtype LogMessage = LogMessage String++instance Searchable LogMessage where+ searchTags (LogMessage m) = return m++instance Renderable LogMessage where+ renderItem () (LogMessage m) = renderItem () m+++--- * the vimus monad+type Tabs = Tab.Tabs AnyWidget++data ProgramState = ProgramState {+ tabView :: Tabs+, mainWindow :: Window+, statusLine :: Window+, tabWindow :: Window+, getLastSearchTerm :: String+, programStateMacros :: Macros+, libraryPath :: Maybe String+, autoTitle :: Bool+, logMessages :: [LogMessage]+, copyRegister :: Vimus [MPD.Path]+}++-- | Put given songs into copy/paste register.+writeCopyRegister :: Vimus [MPD.Path] -> Vimus ()+writeCopyRegister p = modify $ \st -> st {copyRegister = p}++-- | Put given songs into copy/paste register.+readCopyRegister :: Vimus [MPD.Path]+readCopyRegister = join $ gets copyRegister++newtype Vimus a = Vimus {unVimus :: (StateT ProgramState MPD a)}+ deriving (Functor, Applicative, Monad, MonadIO, MonadState ProgramState, MonadError MPDError, MonadMPD)++instance (Default a) => Default (Vimus a) where+ def = return def++runVimus :: Tabs -> Window -> Window -> Window -> Vimus a -> MPD a+runVimus tabs mw statusWindow tw action = evalStateT (unVimus action_) st+ where+ action_ = sendResizeEvent >> action++ st = ProgramState {+ tabView = tabs+ , mainWindow = mw+ , statusLine = statusWindow+ , tabWindow = tw+ , getLastSearchTerm = def+ , programStateMacros = def+ , libraryPath = def+ , autoTitle = False+ , logMessages = def+ , copyRegister = pure []+ }++-- | Free current main window and set a new one.+--+-- This is necessary when the terminal is resized. A resize event is+-- propagated to all widgets, and the screen is updated.+setMainWindow :: Window -> Vimus ()+setMainWindow window = do+ gets mainWindow >>= liftIO . delwin+ modify $ \st -> st {mainWindow = window}+ sendResizeEvent+ renderMainWindow++-- | Propagate size to all widgets.+sendResizeEvent :: Vimus ()+sendResizeEvent = getMainWidgetSize >>= sendEvent . EvResize+++-- * macros++clearMacros :: Vimus ()+clearMacros = putMacros def++-- | Define a macro.+addMacro :: String -- ^ macro+ -> String -- ^ expansion+ -> Vimus ()+addMacro m c = gets programStateMacros >>= \ms -> putMacros (Macro.addMacro m c ms)++removeMacro :: String -> Vimus ()+removeMacro m = do+ macros <- gets programStateMacros+ either printError putMacros (Macro.removeMacro m macros)++getMacros :: Vimus Macros+getMacros = gets programStateMacros++-- a helper+putMacros :: Macros -> Vimus ()+putMacros ms = modify $ \st -> st {programStateMacros = ms}+++-- | Print an error message.+printError :: String -> Vimus ()+printError message = do+ t <- formatTime defaultTimeLocale "%H:%M:%S - " <$> liftIO getZonedTime+ let m = LogMessage (t ++ message)+ modify $ \st -> st {logMessages = m : logMessages st}+ window <- gets statusLine+ liftIO $ do+ werase window+ mvwaddstr window 0 0 message+ mvwchgat window 0 0 (-1) [] ErrorColor+ wrefresh window+ return ()+ sendEvent (EvLogMessage m)++-- | Print a message.+printMessage :: String -> Vimus ()+printMessage message = do+ window <- gets statusLine+ liftIO $ do+ werase window+ mvwaddstr window 0 0 message+ wrefresh window+ return ()++addTab :: TabName -> AnyWidget -> CloseMode -> Vimus ()+addTab name widget mode = do+ modify (\st -> st {tabView = Tab.insert tab (tabView st)})++ -- notify inserted widget about current size+ getMainWidgetSize >>= sendEventCurrent . EvResize++ renderTabBar+ where+ tab = Tab name widget mode++-- | Close current tab if possible, return True on success.+closeTab :: Vimus Bool+closeTab = do+ st <- get+ case Tab.close (tabView st) of+ Just tabs -> do+ put st {tabView = tabs}+ renderTabBar+ return True+ Nothing -> return False++-- | Get path to music library.+getLibraryPath :: Vimus (Maybe FilePath)+getLibraryPath = gets libraryPath++-- | Set path to music library.+--+-- This is need, if you want to use %-expansion in commands.+setLibraryPath :: FilePath -> Vimus ()+setLibraryPath path = liftIO (expandHome path) >>= either printError set+ where+ set p = modify (\state -> state {libraryPath = Just p})++-- | Set the @autotitle@ option.+setAutoTitle :: Bool -> Vimus ()+setAutoTitle x = modify $ \st -> st{autoTitle = x}++getAutoTitle :: Vimus Bool+getAutoTitle = gets autoTitle++modifyTabs :: (Tabs -> Tabs) -> Vimus ()+modifyTabs f = modify (\state -> state { tabView = f $ tabView state })++-- | Set focus to next tab with given name.+selectTab :: TabName -> Vimus ()+selectTab name = do+ modifyTabs $ Tab.select ((== name) . tabName)+ renderTabBar++-- | Set focus to next tab.+nextTab :: Vimus ()+nextTab = do+ modifyTabs Tab.next+ renderTabBar++-- | Set focus to previous tab.+previousTab :: Vimus ()+previousTab = do+ modifyTabs Tab.previous+ renderTabBar++-- | Run given action with currently selected song, if any+withCurrentSong :: Default a => (MPD.Song -> Vimus a) -> Vimus a+withCurrentSong action = do+ widget <- getCurrentWidget+ case currentItem widget of+ Just (Song song) -> action song+ _ -> def++-- | Run given action with currently selected item, if any+withCurrentItem :: Default a => (Content -> Vimus a) -> Vimus a+withCurrentItem action = getCurrentWidget >>= maybe def action . currentItem++-- | Perform an action on all widgets+modifyAllWidgets :: (AnyWidget -> Vimus AnyWidget) -> Vimus ()+modifyAllWidgets action = do+ tabs <- gets tabView >>= mapM action+ modify $ \st -> st {tabView = tabs}++getCurrentWidget :: Vimus AnyWidget+getCurrentWidget = gets (tabContent . Tab.current . tabView)++setCurrentWidget :: AnyWidget -> Vimus ()+setCurrentWidget w = modify (\st -> st {tabView = Tab.modify (w <$) (tabView st)})++-- | Render currently selected widget to main window.+renderMainWindow :: Vimus ()+renderMainWindow = getCurrentWidget >>= renderToMainWindow++-- | Render given widget to main window.+renderToMainWindow :: AnyWidget -> Vimus ()+renderToMainWindow l = do+ window <- gets mainWindow+ ws@(WindowSize sizeY sizeX) <- getMainWidgetSize+ liftIO $ do+ werase window+ ruler <- runRender window 0 0 ws (render l)++ -- one line after the main widget is reserved for the ruler+ let rulerPos = sizeY+ runRender window rulerPos 0 (WindowSize 1 sizeX) (drawRuler ruler)++ wrefresh window+ return ()++-- | Get size of main widget.+getMainWidgetSize :: Vimus WindowSize+getMainWidgetSize = do+ (y, x) <- gets mainWindow >>= liftIO . getmaxyx++ -- one line is reserved for the ruler+ return (WindowSize (pred y) x)++-- |+-- Render the tab bar.+--+-- Needs to be called when ever the current tab changes.+renderTabBar :: Vimus ()+renderTabBar = do++ window <- gets tabWindow+ (pre, c, suf) <- Tab.preCurSuf <$> gets tabView++ let renderTab t = waddstr window $ " " ++ show (tabName t) ++ " "++ liftIO $ do+ werase window++ forM_ pre $ \tab -> do+ waddstr window "|"+ renderTab tab++ -- do not draw current tab if it is AutoClose+ unless (Tab.isAutoClose c) $ do+ waddstr window "|"+ wattr_on window [Bold]+ renderTab c+ wattr_off window [Bold]+ return ()++ waddstr window "|"++ forM_ suf $ \tab -> do+ renderTab tab+ waddstr window "|"++ wrefresh window+ return ()
+ src/Widget/HelpWidget.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE RankNTypes, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Widget.HelpWidget (+ makeHelpWidget++-- exported to silence warnings+, CommandList (..)+, HelpWidget (..)+) where++import Data.List (intercalate)+import Data.Monoid+import Control.Applicative+import Text.Printf (printf)+import Data.String+import Data.List (sortBy)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Ord (comparing)++import Vimus+import Command.Help hiding (help)+import Command.Core (Command, commandName, commandSynopsis)+import Command.Type (commandHelp_)+import Widget.ListWidget (ListWidget)+import qualified Widget.ListWidget as ListWidget+import Widget.TextWidget+import Widget.Type+import Content+import WindowLayout++data HelpWidget = HelpWidget {+ helpWidgetCommandList :: CommandList+, helpWidgetDetailedHelp :: Maybe AnyWidget+}++makeHelpWidget :: [Command] -> Map String [String] -> AnyWidget+makeHelpWidget commands macroGuesses = AnyWidget (HelpWidget commandList Nothing)+ where+ commandList = CommandList (ListWidget.new $ sortBy (comparing commandName) commands) macroGuesses++-- helper for searchItem and filterItem pass-through+passThrough :: (forall a . Widget a => (a -> a)) -> HelpWidget -> HelpWidget+passThrough f (HelpWidget commandList mDetails) = case mDetails of+ Just details -> HelpWidget commandList (Just $ f details)+ Nothing -> HelpWidget (f commandList) Nothing++commandHelp :: Command -> [TextLine]+commandHelp c = TextLine [Colored SuggestionsColor $ commandSynopsis c] : (map (fromString . (" " ++)) . commandHelpText) c++instance Widget HelpWidget where+ render (HelpWidget commandList mDetails) = maybe (render commandList) render mDetails+ currentItem _ = Nothing+ searchItem widget o t = passThrough (\w -> searchItem w o t) widget+ filterItem widget t = passThrough (`filterItem` t) widget++ handleEvent widget@(HelpWidget commandList mDetails) ev = case ev of++ -- switch between command list and details on :default-action+ EvDefaultAction -> maybe moveIn (const moveOut) mDetails++ -- show details on :move-in+ EvMoveIn -> moveIn++ -- go back to command list on :move-out+ EvMoveOut -> moveOut++ -- pass through all other events+ _ -> passThrough_+ where+ passThrough_ = case mDetails of+ Just details -> HelpWidget commandList . Just <$> handleEvent details ev+ Nothing -> (`HelpWidget` Nothing) <$> handleEvent commandList ev++ moveOut = return $ HelpWidget commandList Nothing++ moveIn = return $ case (mDetails, selectCommand commandList) of++ -- command selected, show details+ (Nothing, Just c) -> HelpWidget commandList (Just . makeTextWidget $ commandHelp c)++ -- already showing details (or no command under cursor), do nothing+ _ -> widget++data CommandList = CommandList {+ commandListCommands :: ListWidget () Command+, commandListMacroGuesses :: Map String [String]+}++instance Searchable Command where+ searchTags c = commandName c : concatMap words (unHelp $ commandHelp_ c)++selectCommand :: CommandList -> Maybe Command+selectCommand = ListWidget.select . commandListCommands++instance Widget CommandList where+ render (CommandList w ms) = do+ ListWidget.render (const False) (fmap help w)+ where+ help c = mconcat [TextLine . return . Colored SuggestionsColor . printf "%-30s" $ commandSynopsis c, macros, fromString $ commandShortHelp c]+ where+ -- macros defined for this command+ macros = TextLine . return . Colored InputColor . printf "%-18s " $ maybe "" (intercalate " ") mMacros+ mMacros = Map.lookup (commandName c) ms++ currentItem _ = Nothing+ searchItem (CommandList w ms) o t = CommandList (ListWidget.searchItem w o t) ms+ filterItem (CommandList w ms) t = CommandList (ListWidget.filterItem w t) ms+ handleEvent (CommandList w ms) ev = (`CommandList` ms) <$> ListWidget.handleEvent w ev
+ src/Widget/ListWidget.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Widget.ListWidget (+ ListWidget+, new+, getLength++-- * current element+, getPosition+, select+, breadcrumbs++, selected+, removeSelected++-- * movement+, move+, moveUp+, moveDown+, moveUpWhile+, moveDownWhile+, moveLast+, moveFirst++, moveTo+, setPosition+, noVisual++-- * parent and children+, newChild+, getParent++-- * update+, update+, append+, resize++-- * format+, getElementsFormat+, setElementsFormat++-- * exported, because they have fewer constraints than the Widget variants+, Widget.ListWidget.render+, Widget.ListWidget.searchItem+, Widget.ListWidget.filterItem+, Widget.ListWidget.handleEvent++-- * exported for testing+, getElements+, getViewSize+, getViewPosition+, getVisualStart+, scroll+) where++import Data.List (isInfixOf, intercalate, findIndex)+import Data.Maybe+import Data.Char (toLower)++import Control.Monad (when)+import Data.Foldable (forM_, asum)+import Data.Default++import Widget.Type+import WindowLayout+import Util (clamp)+import Ruler+import Render hiding (getWindowSize)+import Vimus (Widget(..), Event(..), SearchOrder(..))+import Content++data ListWidget f a = ListWidget {+ getPosition :: Int -- ^ Cursor position+, getElements :: [a]+, getFormat :: f+, getLength :: Int+, getVisualStart :: Maybe Int -- ^ First element of visual selection+, windowSize :: WindowSize++-- | position of viewport within the list+, getViewPosition :: Int++, getListParent :: Maybe (ListWidget f a)+} deriving (Eq, Show, Functor)++instance Default f => Default (ListWidget f a) where+ def = ListWidget def def def def def def def def++instance (f ~ Format a, Searchable a, Renderable a) => Widget (ListWidget f a) where+ render = Widget.ListWidget.render (const False)+ currentItem = const Nothing+ searchItem = Widget.ListWidget.searchItem+ filterItem = Widget.ListWidget.filterItem+ handleEvent = Widget.ListWidget.handleEvent++handleEvent :: Monad m => ListWidget f a -> Event -> m (ListWidget f a)+handleEvent l@ListWidget{..} ev = return $ case ev of+ EvMoveUp -> moveUp l+ EvMoveDown -> moveDown l+ EvMoveFirst -> moveFirst l+ EvMoveLast -> moveLast l+ EvScroll n -> scroll n l+ EvResize size -> resize l size+ EvVisual -> if 0 < getLength then l {getVisualStart = Just getPosition} else l+ EvNoVisual -> noVisual True l+ _ -> l++noVisual :: Bool -> ListWidget f a -> ListWidget f a+noVisual keepPosition l@ListWidget{..}+ | keepPosition = l {getVisualStart = Nothing}+ | otherwise = setPosition l {getVisualStart = Nothing} (fromMaybe getPosition getVisualStart)++-- | The number of lines that are available for content.+getViewSize :: ListWidget f a -> Int+getViewSize = windowSizeY . windowSize++getParent :: ListWidget f a -> Maybe (ListWidget f a)+getParent list = fmap (setElementsFormat (getFormat list)) (getListParent list)++new :: Default f => [a] -> ListWidget f a+new = setElements def++newChild :: forall f a. Default f => [a] -> ListWidget f a -> ListWidget f a+newChild list parent = widget {getListParent = Just parent, getFormat = getFormat parent}+ where+ widget :: ListWidget f a+ widget = resize (new list) (windowSize parent)++resize :: ListWidget f a -> WindowSize -> ListWidget f a+resize l@ListWidget{..} size = sanitize $ l {+ windowSize = sanitizeWindowSize size+ , getListParent = (`resize` size) `fmap` getListParent+ }+ where+ -- make sure that the window height is never < 2+ sanitizeWindowSize :: WindowSize -> WindowSize+ sanitizeWindowSize s@WindowSize{..} = s {windowSizeY = max windowSizeY 2}++-- | Make sure that position is within the viewport.+--+-- The viewport is moved, if necessary.+sanitize :: ListWidget f a -> ListWidget f a+sanitize l@ListWidget{..} = setPosition l getPosition++update :: (a -> a -> Bool) -> ListWidget f a -> [a] -> ListWidget f a+update eq widget@ListWidget{..} list = setPosition (setElements widget list) (fromMaybe 0 mNewPos)+ where+ mNewPos = asum $ ys ++ reverse xs+ where+ (xs, ys) = splitAt getPosition $ map ((`findIndex` list) . eq) getElements++-- IMPORTANT: You must call `setPosition` after `setElements`!+setElements :: ListWidget f a -> [a] -> ListWidget f a+setElements widget list = widget {getElements = list, getLength = length list, getListParent = Nothing}++getElementsFormat :: ListWidget f a -> f+getElementsFormat list = getFormat list++setElementsFormat :: f -> ListWidget f a -> ListWidget f a+setElementsFormat format list = list { getFormat = format }++append :: ListWidget f a -> a -> ListWidget f a+append widget@(ListWidget{..}) x = widget{getElements = ys, getLength = length ys}+ where+ ys = getElements ++ [x]++------------------------------------------------------------------------+-- search+++filterItem :: Searchable a => ListWidget f a -> String -> ListWidget f a+filterItem w t = filter_ (filterPredicate t) w+ where+ filter_ :: (a -> Bool) -> ListWidget f a -> ListWidget f a+ filter_ predicate widget = (setElements widget $ filter predicate $ getElements widget) `setPosition` 0++-- | Rotate elements of given list by given number.+--+-- >>> rotate 3 [0..10]+-- [3,4,5,6,7,8,9,10,0,1,2]+rotate :: Int -> [a] -> [a]+rotate n l = drop n l ++ take n l++searchForward :: (a -> Bool) -> ListWidget f a -> ListWidget f a+searchForward predicate widget = maybe widget (setPosition widget) match+ where+ match = findFirst predicate shiftedList+ -- rotate list, to get next match from current position+ shiftedList = rotate n enumeratedList+ where+ n = getPosition widget + 1+ enumeratedList = zip [0..] $ getElements widget++searchBackward :: (a -> Bool) -> ListWidget f a -> ListWidget f a+searchBackward predicate widget = maybe widget (setPosition widget) match+ where+ match = findFirst predicate shiftedList+ -- rotate list, to get next match from current position+ shiftedList = reverse $ rotate n enumeratedList+ where+ n = getPosition widget+ enumeratedList = zip [0..] $ getElements widget++findFirst :: (a -> Bool) -> [(Int, a)] -> Maybe Int+findFirst predicate list = case matches of+ (n, _):_ -> Just n+ _ -> Nothing+ where+ matches = filter predicate_ list+ where+ predicate_ (_, y) = predicate y++searchItem :: Searchable a => ListWidget f a -> SearchOrder -> String -> ListWidget f a+searchItem w Forward t = searchForward (searchPredicate t) w+searchItem w Backward t = searchBackward (searchPredicate t) w++-- | Select given element.+moveTo :: Eq a => a -> ListWidget f a -> Maybe (ListWidget f a)+moveTo c lw = setPosition lw `fmap` findFirst (==c) (zip [0..] $ getElements lw)++data SearchPredicate = Search | Filter++searchPredicate :: Searchable a => String -> a -> Bool+searchPredicate = searchPredicate_ Search++filterPredicate :: Searchable a => String -> a -> Bool+filterPredicate = searchPredicate_ Filter++searchPredicate_ :: Searchable a => SearchPredicate -> String -> a -> Bool+searchPredicate_ predicate "" _ = onEmptyTerm predicate+ where+ onEmptyTerm Search = False+ onEmptyTerm Filter = True+searchPredicate_ _ term item = all (\term_ -> any (isInfixOf term_) tags) terms+ where+ tags = map (map toLower) (searchTags item)+ terms = words $ map toLower term++------------------------------------------------------------------------+-- move++setPosition :: ListWidget f a -> Int -> ListWidget f a+setPosition widget pos = widget { getPosition = newPosition, getViewPosition = newViewPosition }+ where+ newPosition = clamp 0 listLength pos+ listLength = getLength widget+ viewPosition = getViewPosition widget+ minViewPosition = newPosition - (getViewSize widget - 1)+ newViewPosition = max minViewPosition $ min viewPosition newPosition++moveFirst :: ListWidget f a -> ListWidget f a+moveFirst l = setPosition l 0++moveLast :: ListWidget f a -> ListWidget f a+moveLast l = setPosition l (getLength l - 1)++moveUp :: ListWidget f a -> ListWidget f a+moveUp = move (-1)++moveDown :: ListWidget f a -> ListWidget f a+moveDown = move 1++move :: Int -> ListWidget f a -> ListWidget f a+move n l = setPosition l (getPosition l + n)++moveUpWhile :: (a -> Bool) -> ListWidget f a -> ListWidget f a+moveUpWhile p l@ListWidget{..} = setPosition l pos+ where+ pos = getPosition - (length . takeWhile p . reverse . take getPosition) getElements++moveDownWhile :: (a -> Bool) -> ListWidget f a -> ListWidget f a+moveDownWhile p l@ListWidget{..} = setPosition l pos+ where+ pos = getPosition + (length . takeWhile p . drop getPosition) getElements++scroll :: Int -> ListWidget f a -> ListWidget f a+scroll n l = l {getViewPosition = newViewPosition, getPosition = newPosition}+ where+ newViewPosition = clamp 0 (getLength l) (getViewPosition l + n)+ newPosition = clamp newViewPosition (newViewPosition + getViewSize l) (getPosition l)++select :: ListWidget f a -> Maybe a+select l+ | getLength l == 0 = Nothing+ | otherwise = Just (getElements l !! getPosition l)++selected :: ListWidget f a -> [a]+selected ListWidget{..}+ | getLength == 0 = []+ | otherwise = take n $ drop a $ getElements+ where+ start = fromMaybe getPosition getVisualStart+ a = min getPosition start+ b = max getPosition start+ n = succ (b - a)++removeSelected :: ListWidget f a -> ListWidget f a+removeSelected l@ListWidget{..}+ | getLength == 0 = l+ | otherwise = (setElements l (take a getElements ++ drop b getElements) `setPosition` a) {getVisualStart = Nothing}+ where+ start = fromMaybe getPosition getVisualStart+ a = min getPosition start+ b = succ $ max getPosition start++render :: (f ~ Format a, Renderable a) => (a -> Bool) -> ListWidget f a -> Render Ruler+render isMarked l = do+ let listLength = getLength l+ viewSize = getViewSize l+ viewPosition = getViewPosition l+ currentPosition = getPosition l+ format = getElementsFormat l+ visualStart = fromMaybe currentPosition $ getVisualStart l++ when (listLength > 0) $ do++ let isSelected y = a <= y && y <= b+ a = clamp 0 viewSize $ min currentPosition visualStart - viewPosition+ b = clamp 0 viewSize $ max currentPosition visualStart - viewPosition++ list = take viewSize $ drop viewPosition $ getElements l++ forM_ (zip [0..] list) $ \(y, element) -> do+ addLine y 0 (renderItem format element)+ case (isMarked element, isSelected y) of+ (True, True ) -> chgat y [Reverse, Bold] MainColor+ (True, False) -> chgat y [Bold] MainColor+ (False, True ) -> chgat y [Reverse] MainColor+ (False, False) -> return ()++ let positionIndicator+ | listLength > 0 = Just (succ currentPosition, listLength)+ | otherwise = Nothing+ rulerText = maybe "" showBreadcrumbs (getListParent l)+ showBreadcrumbs = intercalate " > " . map (toPlainText . renderItem format) . breadcrumbs++ return $ Ruler rulerText positionIndicator (visible listLength viewSize viewPosition)++-- | Return path to current element.+breadcrumbs :: ListWidget f a -> [a]+breadcrumbs = reverse . go+ where+ go l = maybe id (:) (select l) $ case getListParent l of+ Just p -> go p+ Nothing -> []
+ src/Widget/TextWidget.hs view
@@ -0,0 +1,49 @@+module Widget.TextWidget (makeTextWidget) where++import Data.Foldable (forM_)+import Data.Default++import Vimus+import Ruler+import Util (clamp)+import Render+import Widget.Type++makeTextWidget :: [TextLine] -> AnyWidget+makeTextWidget content = AnyWidget def {textWidgetContent = content}++data TextWidget = TextWidget {+ textWidgetContent :: [TextLine]+, textWidgetViewSize :: WindowSize+, textWidgetPosition :: Int+}++instance Default TextWidget where+ def = TextWidget def def def++instance Widget TextWidget where+ render (TextWidget content (WindowSize sizeY _) pos) = do+ forM_ (zip [0 .. pred sizeY] (drop pos content)) $ \(y, c) -> do+ addLine y 0 c+ let visibleIndicator = visible (length content) sizeY pos+ return (Ruler "" Nothing visibleIndicator)++ currentItem _ = Nothing+ searchItem w _ _ = w+ filterItem w _ = w+ handleEvent widget@(TextWidget content (WindowSize sizeY _) pos) ev = return $ case ev of+ EvResize size -> widget {textWidgetViewSize = size}+ EvMoveUp -> scroll (-1)+ EvMoveDown -> scroll 1+ EvMoveFirst -> widget {textWidgetPosition = 0}+ EvMoveLast -> moveLast+ EvScroll n -> scroll n+ _ -> widget+ where+ scroll n = widget {textWidgetPosition = clamp 0 (length content) (pos + n)}+ moveLast+ -- if current position is greater than new position, keep it+ | newPos < pos = widget+ | otherwise = widget {textWidgetPosition = newPos}+ where+ newPos = max (length content - sizeY) 0
+ src/Widget/Type.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}+module Widget.Type where++import Data.String+import Data.Monoid+import Data.Default+import WindowLayout++data WindowSize = WindowSize {+ windowSizeY :: Int+, windowSizeX :: Int+} deriving (Eq, Show)++instance Default WindowSize where+ def = WindowSize 25 80++-- | A chunk of text, possibly colored.+data Chunk = Colored WindowColor String | Plain String++instance IsString Chunk where+ fromString = Plain++-- | A line of text.+newtype TextLine = TextLine {unTextLine :: [Chunk]}++toPlainText :: TextLine -> String+toPlainText = concatMap unChunk . unTextLine+ where+ unChunk (Plain s) = s+ unChunk (Colored _ s) = s++instance Monoid TextLine where+ mempty = TextLine []+ xs `mappend` ys = TextLine (unTextLine xs ++ unTextLine ys)++instance IsString TextLine where+ fromString = TextLine . return . fromString++class Renderable a where+ type Format a+ type Format a = ()+ renderItem :: Format a -> a -> TextLine++instance Renderable String where+ renderItem () = fromString++instance Renderable TextLine where+ renderItem () = id
+ src/WindowLayout.hs view
@@ -0,0 +1,92 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module WindowLayout (+ Attribute (..)+, WindowColor (MainColor, RulerColor, TabColor, InputColor, PlayStatusColor, SongStatusColor, ErrorColor, SuggestionsColor)+, Color, black, red, green, yellow, blue, magenta, cyan, white+, defaultColor+, create+, wchgat+, mvwchgat+, wcolor_set+, defineColor+) where++import Control.Monad+import UI.Curses hiding (wchgat, mvwchgat, wcolor_set)+import qualified UI.Curses as Curses++-- ReservedColor (color pair 0) cannot be modified, so we do not use it.+{-# WARNING ReservedColor "Do not use this!" #-}+data WindowColor =+ ReservedColor+ | MainColor+ | RulerColor+ | TabColor+ | InputColor+ | PlayStatusColor+ | SongStatusColor+ | ErrorColor+ | SuggestionsColor+ deriving (Show, Enum, Bounded)++defaultColor :: Color+defaultColor = Color (-1)++defineColor :: WindowColor -> Color -> Color -> IO ()+defineColor color fg bg = init_pair (fromEnum color) fg bg >> return ()++setWindowColor :: WindowColor -> Window -> IO Status+setWindowColor color window = wbkgd window (color_pair . fromEnum $ color)++wchgat :: Window -> Int -> [Attribute] -> WindowColor -> IO ()+wchgat window n attr color = void $ Curses.wchgat window n attr (fromEnum color)++mvwchgat :: Window -> Int -> Int -> Int -> [Attribute] -> WindowColor -> IO ()+mvwchgat window y x n attr color = void $ Curses.mvwchgat window y x n attr (fromEnum color)++wcolor_set :: Window -> WindowColor -> IO ()+wcolor_set window color = void $ Curses.wcolor_set window (fromEnum color)++-- | Set given color pair to default/default+resetColor :: WindowColor -> IO ()+resetColor c = defineColor c defaultColor defaultColor >> return ()++-- | Set all color pairs to default/default+resetColors :: IO ()+resetColors = mapM_ resetColor [toEnum 1 .. maxBound]++create :: IO (IO Window, Window, Window, Window, Window, Window)+create = do++ resetColors++ let createMainWindow = do+ (sizeY, _) <- getmaxyx stdscr+ let mainWinSize = sizeY - 4+ window <- newwin mainWinSize 0 1 0+ setWindowColor MainColor window+ return (window, 0, mainWinSize + 1, mainWinSize + 2, mainWinSize + 3)++ (mainWindow, pos0, pos2, pos3, pos4) <- createMainWindow+ tabWindow <- newwin 1 0 pos0 0+ songStatusWindow <- newwin 1 0 pos2 0+ playStatusWindow <- newwin 1 0 pos3 0+ inputWindow <- newwin 1 0 pos4 0++ setWindowColor TabColor tabWindow+ setWindowColor InputColor inputWindow+ setWindowColor PlayStatusColor playStatusWindow+ setWindowColor SongStatusColor songStatusWindow++ let onResize = do+ (newMainWindow, newPos0, newPos2, newPos3, newPos4) <- createMainWindow+ mvwin tabWindow newPos0 0+ mvwin songStatusWindow newPos2 0+ mvwin playStatusWindow newPos3 0+ mvwin inputWindow newPos4 0+ wrefresh songStatusWindow+ wrefresh playStatusWindow+ wrefresh inputWindow+ return newMainWindow++ return (onResize, tabWindow, mainWindow, songStatusWindow, playStatusWindow, inputWindow)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ vimus.cabal view
@@ -0,0 +1,127 @@+name: vimus+version: 0.1.0+synopsis: An MPD client with vim-like key bindings+description: An MPD client with vim-like key bindings+ .+ <https://github.com/vimus/vimus#readme>+category: Sound+license: MIT+license-file: LICENSE+author: Simon Hengel <sol@typeful.net>+maintainer: Simon Hengel <sol@typeful.net>+build-type: Simple+cabal-version: >= 1.10++data-dir:+ resource+data-files:+ default-mappings+ emacs-mappings++extra-source-files:+ ncursesw/src/mycurses.h++source-repository head+ type: git+ location: git://github.com/vimus/vimus.git++library+ exposed: False+ default-language: Haskell2010+ ghc-options: -Wall++ build-depends:+ base >= 4.7 && < 5+ , bytestring+ , utf8-string+ , wcwidth+ , libmpd == 0.9.*+ , mtl >= 2+ , containers >= 0.4 && < 0.6+ , deepseq+ , time+ , old-locale+ , process+ , filepath+ , directory+ , data-default+ , template-haskell+ hs-source-dirs:+ src+ , ncursesw/src+ exposed-modules:+ Run+ Command+ Command.Type+ Command.Core+ Command.Help+ Command.Completion+ Command.Parser+ Content+ Input+ Key+ Ruler+ Widget.Type+ Widget.TextWidget+ Widget.ListWidget+ Widget.HelpWidget+ Macro+ Option+ PlaybackState+ Queue+ Song+ Song.Format+ Tab+ Timer+ Type+ Util+ Vimus+ Render+ WindowLayout+ Paths_vimus+ Data.List.Pointed+ Data.List.Zipper++ -- ncursesw+ build-tools: c2hs+ extra-libraries: ncursesw+ include-dirs: /usr/include/ncursesw ncursesw/src+ includes: mycurses.h+ c-sources: ncursesw/src/cbits.c++ exposed-modules:+ UI.Curses+ UI.Curses.Key+ UI.Curses.Type+ Curses+ Constant+ CursesUtil+ Misc+ CursesInput++executable vimus+ default-language: Haskell2010+ ghc-options: -Wall -threaded+ main-is: Main.hs+ hs-source-dirs: driver+ build-depends:+ base >= 4.7 && < 5+ , vimus++test-suite spec+ default-language: Haskell2010+ ghc-options: -Wall -threaded+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ build-depends:+ base >= 4.7 && < 5+ , vimus+ , data-default+ , wcwidth+ , mtl++ , hspec >= 1.3+ , hspec-expectations+ , transformers+ , QuickCheck