-- -- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- Copyright (c) 2008, 2019-2022 Galen Huntington -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as -- published by the Free Software Foundation; either version 2 of -- the License, or (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -- -- -- | Keymap manipulation -- -- The idea of using lazy lexers to implement keymaps is described in -- the paper: -- -- > Dynamic Applications From the Ground Up. Don Stewart and Manuel M. -- > T. Chakravarty. In Proceedings of the ACM SIGPLAN Workshop on -- > Haskell, pages 27-38. ACM Press, 2005. -- -- See that for more info. -- module Keymap where import Prelude () import Base hiding (all) import Core import Config (package) import State (getsST, touchST, HState(helpVisible, playHist)) import Style (defaultSty, StringA(Fast)) import qualified UI (resetui) import Lexers ((>||<),action,meta,execLexer ,alt,with,char,Regexp,Lexer) import UI.HSCurses.Curses (Key(..), decodeKey) import qualified Data.ByteString.Char8 as P import qualified Data.Map as M import qualified Data.Sequence as Seq data Direction = Forwards | Backwards data Zipper = Zipper { cur :: !String, back :: ![String], front :: ![String] } data SearchWhat = SearchFiles | SearchDirs data SearchType = SearchType { schChar :: !Char , schWhat :: !SearchWhat , schDir :: !Direction } data SearchSpec = SearchSpec { schType :: !SearchType , schZipper :: !Zipper } data SearchState = SearchState { schHist :: ![String] , schSpec :: SearchSpec } type LexerS = Lexer SearchState (IO ()) type Result = Maybe (Either String (IO ())) type MetaTarget = (Result, SearchState, Maybe LexerS) -- -- The keymap -- keymap :: [Char] -> [IO ()] keymap cs = map (clrmsg *>) actions where (actions,_,_) = execLexer allKeys (cs, SearchState [] undefined) allKeys :: LexerS allKeys = commands >||< search >||< history >||< confirmQuit commands :: LexerS commands = alt keys `action` \[c] -> Just $ fromMaybe (pure ()) $ M.lookup c keyMap ------------------------------------------------------------------------ search :: LexerS search = searchDirs >||< searchFiles searchStart :: Char -> SearchWhat -> Direction -> LexerS searchStart c typ dir = char c `meta` \_ (SearchState hist _) -> (with (toggleFocus *> putmsg (Fast (P.singleton c) defaultSty) *> touchST) , SearchState hist $ SearchSpec (SearchType c typ dir) (Zipper "" hist []) , Just dosearch) searchDirs :: LexerS searchDirs = searchStart '\\' SearchDirs Forwards >||< searchStart '|' SearchDirs Backwards searchFiles :: LexerS searchFiles = searchStart '/' SearchFiles Forwards >||< searchStart '?' SearchFiles Backwards dosearch :: LexerS dosearch = search_char >||< search_bs >||< search_up >||< search_down >||< search_esc >||< search_eval endSearchWith :: IO () -> [String] -> MetaTarget endSearchWith a hist = (with (a *> toggleFocus), SearchState hist undefined, Just allKeys) -- "lens" zipEdit :: (String -> String) -> Zipper -> Zipper zipEdit f zipp = zipp{cur = f $ cur zipp} printSearch :: SearchSpec -> Maybe (Either a (IO ())) printSearch spec = with do putmsg $ Fast (P.pack $ schChar (schType spec) : cur (schZipper spec)) defaultSty touchST updateSearch :: (Zipper -> Zipper) -> SearchState -> MetaTarget updateSearch f st@(SearchState _ spec) = let spec' = spec{ schZipper = f $ schZipper spec } in (printSearch spec', st{schSpec=spec'}, Just dosearch) search_char :: LexerS search_char = anyNonSpecial `meta` \c -> updateSearch $ zipEdit (++ c) where anyNonSpecial = alt $ any' \\ (enter' ++ delete' ++ ['\ESC']) search_bs :: LexerS search_bs = delete `meta` \_ -> updateSearch $ zipEdit \case [] -> []; xs -> init xs search_up :: LexerS search_up = char (unkey KeyUp) `meta` \_ -> updateSearch \case Zipper cur (nx:rest) front -> Zipper nx rest (cur:front) zipp -> zipp search_down :: LexerS search_down = char (unkey KeyDown) `meta` \_ -> updateSearch \case Zipper cur back (pv:rest) -> Zipper pv (cur:back) rest zipp -> zipp search_esc :: LexerS search_esc = char '\ESC' `meta` \_ (SearchState hist _) -> endSearchWith (clrmsg *> touchST) hist search_eval :: LexerS search_eval = enter `meta` \_ (SearchState hist spec) -> case cur $ schZipper spec of [] -> endSearchWith (clrmsg *> touchST) hist pat -> let typ = schType spec jumpy = case schWhat typ of SearchFiles -> jumpToMatchFile SearchDirs -> jumpToMatch in endSearchWith do jumpy (Just pat) case schDir typ of Forwards -> True; _ -> False do if take 1 hist == [pat] then hist else pat : hist ------------------------------------------------------------------------ history :: LexerS history = alt ['H', ';'] `meta` \_ st -> (with (showHist *> touchST), st, Just inner) where inner = alt any' `meta` (\_ st -> (with (hideHist *> touchST), st, Just allKeys)) >||< alt ['0'..'9'] `meta` handleKey '0' 0 >||< alt ['a'..'z'] `meta` handleKey 'a' 10 handleKey base off cs st = (with do ph <- getsST playHist whenJust do ph Seq.!? (fromEnum (head cs) - (fromEnum base - off)) do jump . snd hideHist touchST , st , Just allKeys ) ------------------------------------------------------------------------ confirmQuit :: LexerS confirmQuit = char 'q' `meta` \_ st -> (with (forcePause *> toggleExit *> touchST), st, Just inner) where inner = alt any' `meta` (\_ st -> (with (toggleExit *> touchST), st, Just allKeys)) >||< char 'y' `meta` (\_ st -> (with $ quit Nothing, st, Nothing)) ------------------------------------------------------------------------ -- "Key"s seem to be inscrutable and incomparable. -- So, add an orphan instance to help translate to chars. deriving instance Ord Key charToKey :: Char -> Key charToKey = decodeKey . toEnum . fromEnum keyCharMap :: M.Map Key Char keyCharMap = M.fromList [(charToKey c, c) | c <- ['\0' .. '\377']] unkey :: Key -> Char unkey k = fromMaybe '\0' $ M.lookup k keyCharMap enter', any', digit', delete' :: [Char] enter' = ['\n', '\r'] delete' = ['\BS', '\127', unkey KeyBackspace] any' = ['\0' .. '\255'] digit' = ['0' .. '9'] delete, enter :: Regexp SearchState (IO ()) delete = alt delete' enter = alt enter' ------------------------------------------------------------------------ -- -- The default keymap, and its description -- keyTable :: [(String, [Char], IO ())] keyTable = [ ("Move up", ['k',unkey KeyUp], up) ,("Move down", ['j',unkey KeyDown], down) ,("Page down", [unkey KeyNPage], downPage) ,("Page up", [unkey KeyPPage], upPage) ,("Jump to start of list", [unkey KeyHome,'0'], jump 0) ,("Jump to end of list", [unkey KeyEnd,'G'], jump maxBound) ,("Jump to 10%, 20%, 30%, etc., point", ['1','2','3'], undefined) -- overridden below ,("Seek left within song", [unkey KeyLeft], seekLeft) ,("Seek right within song", [unkey KeyRight], seekRight) ,("Toggle pause", [' '], pause) ,("Play song under cursor", ['\n'], play) ,("Play previous track", ['K'], playPrev) ,("Play next track", ['J'], playNext) ,("Toggle the help screen", ['h'], toggleHelp) ,("Jump to currently playing song", ['t'], jumpToPlaying) ,("Select and play next track", ['d'], playNext *> jumpToPlaying) ,("Cycle through normal, random, and loop modes", ['m'], nextMode) ,("Refresh the display", ['\^L'], UI.resetui) ,("Repeat last regex search", ['n'], jumpToMatchFile Nothing True) ,("Repeat last regex search backwards", ['N'], jumpToMatchFile Nothing False) ,("Play", ['p'], playCur) ,("Mark for deletion in ~/.hmp3-delete", ['D'], blacklist) ,("Load config file", ['l'], loadConfig) ,("Restart song", [unkey KeyBackspace], seekStart) ] innerTable :: [(Char, IO ())] innerTable = [(c, jumpRel i) | (i, c) <- zip [0.1, 0.2 ..] ['1'..'9']] extraTable :: [(String, [Char])] extraTable = [("Toggle the song history", ['H', ';']) ,("Search for file matching regex", ['/']) ,("Search backwards for file", ['?']) ,("Search for directory matching regex", ['\\']) ,("Search backwards for directory", ['|']) -- ,("Quit (or close help screen)", ['q']) ,("Quit " ++ package, ['q']) ] helpIsVisible :: IO Bool helpIsVisible = getsST helpVisible keyMap :: M.Map Char (IO ()) keyMap = M.fromList $ [ (c,a) | (_,cs,a) <- keyTable, c <- cs ] ++ innerTable keys :: [Char] keys = concat [ cs | (_,cs,_) <- keyTable ] ++ map fst innerTable