vimus 0.1.0.1 → 0.2.0
raw patch · 53 files changed
+3925/−3912 lines, 53 files
Files
- LICENSE +6/−1
- driver/Main.hs +2/−2
- src/Command.hs +0/−899
- src/Command/Completion.hs +0/−69
- src/Command/Core.hs +0/−175
- src/Command/Help.hs +0/−63
- src/Command/Parser.hs +0/−95
- src/Command/Type.hs +0/−32
- src/Content.hs +2/−2
- src/Input.hs +0/−240
- src/Instances.hs +15/−0
- src/Key.hs +0/−212
- src/Macro.hs +0/−89
- src/PlaybackState.hs +1/−1
- src/Queue.hs +0/−27
- src/Render.hs +0/−93
- src/Ruler.hs +0/−45
- src/Run.hs +0/−281
- src/Song.hs +0/−74
- src/Song/Format.hs +0/−131
- src/Tab.hs +0/−146
- src/Type.hs +0/−15
- src/Util.hs +0/−83
- src/Vimus.hs +0/−467
- src/Vimus/Command.hs +899/−0
- src/Vimus/Command/Completion.hs +69/−0
- src/Vimus/Command/Core.hs +175/−0
- src/Vimus/Command/Help.hs +63/−0
- src/Vimus/Command/Parser.hs +95/−0
- src/Vimus/Command/Type.hs +32/−0
- src/Vimus/Input.hs +240/−0
- src/Vimus/Key.hs +212/−0
- src/Vimus/Macro.hs +89/−0
- src/Vimus/Queue.hs +27/−0
- src/Vimus/Render.hs +93/−0
- src/Vimus/Ruler.hs +45/−0
- src/Vimus/Run.hs +281/−0
- src/Vimus/Song.hs +74/−0
- src/Vimus/Song/Format.hs +131/−0
- src/Vimus/Tab.hs +146/−0
- src/Vimus/Type.hs +467/−0
- src/Vimus/Util.hs +83/−0
- src/Vimus/Widget/HelpWidget.hs +109/−0
- src/Vimus/Widget/ListWidget.hs +347/−0
- src/Vimus/Widget/TextWidget.hs +49/−0
- src/Vimus/Widget/Type.hs +48/−0
- src/Vimus/WindowLayout.hs +92/−0
- src/Widget/HelpWidget.hs +0/−109
- src/Widget/ListWidget.hs +0/−347
- src/Widget/TextWidget.hs +0/−49
- src/Widget/Type.hs +0/−48
- src/WindowLayout.hs +0/−92
- vimus.cabal +33/−25
LICENSE view
@@ -1,4 +1,9 @@-Copyright (c) 2010-2014 `git shortlog`+Copyright (c) 2010-2014 Simon Hengel+Copyright (c) 2010-2014 Markus Klinik+Copyright (c) 2012-2014 Niklas Haas+Copyright (c) 2012-2014 Joachim Fasting+Copyright (c) 2012-2014 Sylvain Henry+Copyright (c) 2013-2014 Matvey Aksenov Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
driver/Main.hs view
@@ -1,5 +1,5 @@ module Main where-import qualified Run+import qualified Vimus.Run main :: IO ()-main = Run.main+main = Vimus.Run.main
− src/Command.hs
@@ -1,899 +0,0 @@-{-# 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
@@ -1,69 +0,0 @@-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
@@ -1,175 +0,0 @@-{-# 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
@@ -1,63 +0,0 @@-{-# 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
@@ -1,95 +0,0 @@-{-# 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
@@ -1,32 +0,0 @@-{-# 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
@@ -10,8 +10,8 @@ import qualified Network.MPD as MPD hiding (withMPD) import qualified System.FilePath as FilePath -import Widget.Type-import Song.Format (SongFormat(..))+import Vimus.Widget.Type+import Vimus.Song.Format (SongFormat(..)) pathFileName :: MPD.Path -> String pathFileName = FilePath.takeFileName . MPD.toString
− src/Input.hs
@@ -1,240 +0,0 @@-{-# 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/Instances.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | orphan instances+module Instances 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/Key.hs
@@ -1,212 +0,0 @@-{-# 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
@@ -1,89 +0,0 @@-{-# 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/PlaybackState.hs view
@@ -20,7 +20,7 @@ import Timer -import Type ()+import Instances () data State = State { timer :: Maybe Timer
− src/Queue.hs
@@ -1,27 +0,0 @@--- | 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
@@ -1,93 +0,0 @@-{-# 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
@@ -1,45 +0,0 @@-{-# 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
@@ -1,281 +0,0 @@-{-# 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
@@ -1,74 +0,0 @@--- | 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
@@ -1,131 +0,0 @@--- | 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
@@ -1,146 +0,0 @@-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/Type.hs
@@ -1,15 +0,0 @@-{-# 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
@@ -1,83 +0,0 @@-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
@@ -1,467 +0,0 @@-{-# 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/Vimus/Command.hs view
@@ -0,0 +1,899 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes, TupleSections, RecordWildCards #-}+module Vimus.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 Vimus.Util+import Vimus.Type+import Vimus.Widget.ListWidget (ListWidget)+import qualified Vimus.Widget.ListWidget as ListWidget+import Vimus.Widget.HelpWidget+import Content+import Vimus.WindowLayout+import Vimus.Key (ExpandKeyError (..), keyNames, expandKeys)+import qualified Vimus.Macro as Macro+import Vimus.Input (CompletionFunction)+import Vimus.Command.Core+import Vimus.Command.Help (help)+import Vimus.Command.Parser+import Vimus.Command.Completion++import Vimus.Tab (Tabs)+import qualified Vimus.Tab as Tab+import Vimus.Song.Format (SongFormat)+import Vimus.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/Vimus/Command/Completion.hs view
@@ -0,0 +1,69 @@+module Vimus.Command.Completion (+ completeCommand+, parseCommand+, completeOptions+, completeOptions_+) where++import Data.List+import Data.Char++import Vimus.Util+import Vimus.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/Vimus/Command/Core.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-}+module Vimus.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.Type (Vimus)+import Text.Read (readMaybe)+import Vimus.WindowLayout (WindowColor(..), defaultColor)+import UI.Curses (Color, black, red, green, yellow, blue, magenta, cyan, white)+import Vimus.Command.Type+import Vimus.Command.Help () -- for the (IsString Help) instance+import Vimus.Command.Completion+import Vimus.Command.Parser+import Vimus.Song.Format (SongFormat)+import qualified Vimus.Song.Format as SongFormat+import qualified Vimus.Song as 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/Vimus/Command/Help.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Vimus.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 Vimus.Command.Type+import Vimus.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/Vimus/Command/Parser.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE DeriveFunctor #-}+module Vimus.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/Vimus/Command/Type.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Vimus.Command.Type (+ module Vimus.Command.Type+, CompletionFunction+, noCompletion+) where++import Control.Applicative++import Vimus.Type+import Vimus.Input (CompletionFunction, noCompletion)+import Vimus.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/Vimus/Input.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Vimus.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 Vimus.WindowLayout+import Vimus.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/Vimus/Key.hs view
@@ -0,0 +1,212 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Vimus.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/Vimus/Macro.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-}+module Vimus.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 Vimus.Key (unExpandKeys)++import Vimus.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/Vimus/Queue.hs view
@@ -0,0 +1,27 @@+-- | A simple unbounded queue.+--+-- All operations are non-blocking.+module Vimus.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/Vimus/Render.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Vimus.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 Vimus.Widget.Type+import Vimus.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/Vimus/Ruler.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Vimus.Ruler where++import Text.Printf (printf)++import Vimus.WindowLayout+import Vimus.Render+import Vimus.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/Vimus/Run.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Vimus.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 Vimus.WindowLayout as WindowLayout+import qualified Vimus.Input as Input+import Vimus.Input (HistoryNamespace(..), noCompletion)+import Vimus.Macro+import qualified PlaybackState+import Option (getOptions)+import Vimus.Util (expandHome)+import Vimus.Queue+import Vimus.Type+import qualified Vimus.Command as Command+import qualified Vimus.Song as 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/Vimus/Song.hs view
@@ -0,0 +1,74 @@+-- | Songs metadata+module Vimus.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/Vimus/Song/Format.hs view
@@ -0,0 +1,131 @@+-- | Song format parser+module Vimus.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 Vimus.Command.Parser as Parser++import Vimus.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/Vimus/Tab.hs view
@@ -0,0 +1,146 @@+module Vimus.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/Vimus/Type.hs view
@@ -0,0 +1,467 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Vimus.Type (+ 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 Vimus.Macro as Macro+import Vimus.Macro (Macros)++import Content+import Instances ()+import Vimus.Widget.Type++import Vimus.Tab (Tab(..), TabName(..), CloseMode(..))+import qualified Vimus.Tab as Tab+import Vimus.WindowLayout (WindowColor(..), mvwchgat)++import Control.Monad.Error.Class+import Vimus.Util (expandHome)+import Vimus.Render+import Vimus.Ruler++import Vimus.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/Vimus/Util.hs view
@@ -0,0 +1,83 @@+module Vimus.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/Widget/HelpWidget.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE RankNTypes, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Vimus.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.Type+import Vimus.Command.Help hiding (help)+import Vimus.Command.Core (Command, commandName, commandSynopsis)+import Vimus.Command.Type (commandHelp_)+import Vimus.Widget.ListWidget (ListWidget)+import qualified Vimus.Widget.ListWidget as ListWidget+import Vimus.Widget.TextWidget+import Vimus.Widget.Type+import Content+import Vimus.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/Vimus/Widget/ListWidget.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Vimus.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+, Vimus.Widget.ListWidget.render+, Vimus.Widget.ListWidget.searchItem+, Vimus.Widget.ListWidget.filterItem+, Vimus.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 Vimus.Widget.Type+import Vimus.WindowLayout+import Vimus.Util (clamp)+import Vimus.Ruler+import Vimus.Render hiding (getWindowSize)+import Vimus.Type (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 = Vimus.Widget.ListWidget.render (const False)+ currentItem = const Nothing+ searchItem = Vimus.Widget.ListWidget.searchItem+ filterItem = Vimus.Widget.ListWidget.filterItem+ handleEvent = Vimus.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/Vimus/Widget/TextWidget.hs view
@@ -0,0 +1,49 @@+module Vimus.Widget.TextWidget (makeTextWidget) where++import Data.Foldable (forM_)+import Data.Default++import Vimus.Type+import Vimus.Ruler+import Vimus.Util (clamp)+import Vimus.Render+import Vimus.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/Vimus/Widget/Type.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}+module Vimus.Widget.Type where++import Data.String+import Data.Monoid+import Data.Default+import Vimus.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/Vimus/WindowLayout.hs view
@@ -0,0 +1,92 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Vimus.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)
− src/Widget/HelpWidget.hs
@@ -1,109 +0,0 @@-{-# 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
@@ -1,347 +0,0 @@-{-# 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
@@ -1,49 +0,0 @@-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
@@ -1,48 +0,0 @@-{-# 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
@@ -1,92 +0,0 @@-{-# 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)
vimus.cabal view
@@ -1,5 +1,5 @@ name: vimus-version: 0.1.0.1+version: 0.2.0 synopsis: An MPD client with vim-like key bindings description: An MPD client with vim-like key bindings .@@ -7,6 +7,12 @@ category: Sound license: MIT license-file: LICENSE+copyright: (c) 2010-2014 Simon Hengel,+ (c) 2010-2014 Markus Klinik,+ (c) 2012-2014 Niklas Haas,+ (c) 2012-2014 Joachim Fasting,+ (c) 2012-2014 Sylvain Henry,+ (c) 2013-2014 Matvey Aksenov author: Simon Hengel <sol@typeful.net> maintainer: Simon Hengel <sol@typeful.net> build-type: Simple@@ -50,34 +56,35 @@ src , ncursesw/src exposed-modules:- Run- Command- Command.Type- Command.Core- Command.Help- Command.Completion- Command.Parser+ Vimus.Run+ Vimus.Command+ Vimus.Command.Type+ Vimus.Command.Core+ Vimus.Command.Help+ Vimus.Command.Completion+ Vimus.Command.Parser+ Vimus.Input+ Vimus.Key+ Vimus.Ruler+ Vimus.Widget.Type+ Vimus.Widget.ListWidget+ Vimus.Widget.TextWidget+ Vimus.Widget.HelpWidget+ Vimus.Macro+ Vimus.Queue+ Vimus.Util+ Vimus.Type+ Vimus.Render+ Vimus.WindowLayout+ Vimus.Song+ Vimus.Song.Format+ Vimus.Tab+ other-modules: 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+ Instances Paths_vimus Data.List.Pointed Data.List.Zipper@@ -93,6 +100,7 @@ UI.Curses UI.Curses.Key UI.Curses.Type+ other-modules: Curses Constant CursesUtil