hmp3-ng-2.17.0: Keymap.hs
--
-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons
-- Copyright (c) 2008, 2019-2025 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, delete)
import Core
import Config (package)
import State (getsST, touchST, HState(helpVisible, histVisible))
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
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_del
>||< 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 sst@(SearchState _ spec) =
let spec' = spec{ schZipper = f $ schZipper spec }
in (printSearch spec', sst{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_del :: LexerS
search_del = char (unkey KeyDC) `meta` \_ -> updateSearch \case
Zipper _ back (pv:rest) -> Zipper pv back rest
Zipper _ back _ -> Zipper "" back []
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`
\_ sst -> (with (showHist *> touchST), sst, Just inner) where
inner =
alt any' `meta` (\_ sst -> (with (hideHist *> touchST), sst, Just allKeys))
>||< alt ['0'..'9'] `meta` handleKey '0' 0
>||< alt ['a'..'z'] `meta` handleKey 'a' 10
handleKey base off cs sst =
(with do
phm <- getsST histVisible
for_
do phm >>= (!? (fromEnum (head cs) - (fromEnum base - off)))
do jump . fst . snd
hideHist
touchST
, sst
, Just allKeys
)
-- Compatibility: List.!? only added in GHC 9.8
xs !? n = listToMaybe $ drop n xs
------------------------------------------------------------------------
confirmQuit :: LexerS
confirmQuit = char 'q' `meta`
\_ sst -> (with (forcePause *> toggleExit *> touchST), sst, Just inner) where
inner = alt any' `meta` (\_ sst -> (with (toggleExit *> touchST), sst, Just allKeys))
>||< char 'y' `meta` (\_ sst -> (with $ quit Nothing, sst, Nothing))
------------------------------------------------------------------------
-- "Key"s seem to be inscrutable and incomparable.
-- So, add an orphan instance to help translate to chars.
deriving stock 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', '\DEL', 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