Keymap.hs

-- 
-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons
-- Copyright (c) 2008, 2019-2024 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
            for_
                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 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', '\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