diff --git a/Base.hs b/Base.hs --- a/Base.hs +++ b/Base.hs @@ -1,23 +1,7 @@ {-# LANGUAGE CPP #-} --- --- Copyright (c) 2020-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. --- +-- Copyright (c) 2020-2025 Galen Huntington +-- SPDX-License-Identifier: GPL-2.0-or-later module Base (module Prelude, module X, module Base) where diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -1,70 +1,68 @@ --- -- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- Copyright (c) 2019-2021 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. --- +-- SPDX-License-Identifier: GPL-2.0-or-later + module Config where +import qualified Data.Map as M + import Base import Style import Paths_hmp3_ng (version) +-- XXX some styles are currently unused, but planned is a CLI option to select + +fixedStyles :: M.Map String UIStyle +fixedStyles = M.fromList + [ ("default", defaultStyle) + , ("dark", defaultStyle) + , ("light", lightBgStyle) + , ("mono", bwStyle) + , ("mutt", muttStyle) + ] + defaultStyle :: UIStyle -defaultStyle = UIStyle { window = Style defaultfg defaultbg - , titlebar = Style brightwhite green - , selected = Style blue defaultbg - , cursors = Style black cyan - , combined = Style brightwhite cyan - , warnings = Style red defaultbg - , modals = Style black white - , blockcursor= Style black red - , progress = Style cyan white } +defaultStyle = UIStyle { window = style "default" "default" + , titlebar = style "brightwhite" "green" + , selected = style "blue" "default" + , cursors = style "black" "cyan" + , combined = style "brightwhite" "cyan" + , warnings = style "red" "default" + , modals = style "black" "white" + , blockcursor= style "black" "red" + , progress = style "cyan" "white" } --- | A style more suitable for light backgrounds (used if HMP_HAS_LIGHT_BG=true) +-- | A style more suitable for light backgrounds lightBgStyle :: UIStyle lightBgStyle = - defaultStyle { selected = Style darkblue defaultbg - , warnings = Style darkred defaultbg } + defaultStyle { selected = style "darkblue" "default" + , warnings = style "darkred" "default" } -- -- | Another style for dark backgrounds, reminiscent of mutt -- muttStyle :: UIStyle -muttStyle = UIStyle { window = Style brightwhite black - , titlebar = Style green blue - , selected = Style brightwhite black - , cursors = Style black cyan - , combined = Style black cyan - , warnings = Style brightwhite red - , modals = Style black cyan - , blockcursor= Style black darkred - , progress = Style cyan white } +muttStyle = UIStyle { window = style "brightwhite" "black" + , titlebar = style "green" "blue" + , selected = style "brightwhite" "black" + , cursors = style "black" "cyan" + , combined = style "black" "cyan" + , warnings = style "brightwhite" "red" + , modals = style "black" "cyan" + , blockcursor= style "black" "darkred" + , progress = style "cyan" "white" } bwStyle :: UIStyle bwStyle = UIStyle { - window = Style defaultfg defaultbg - ,titlebar = Style reversefg reversebg - ,selected = Style brightwhite defaultbg - ,cursors = Style reversefg reversebg - ,combined = Style reversefg reversebg - ,warnings = Style reversefg reversebg - ,modals = Style reversefg reversebg - ,blockcursor = Style reversefg reversebg - ,progress = Style reversefg reversebg + window = style "default" "default" + ,titlebar = style "reverse" "reverse" + ,selected = style "brightwhite" "default" + ,cursors = style "reverse" "reverse" + ,combined = style "reverse" "reverse" + ,warnings = style "reverse" "reverse" + ,modals = style "reverse" "reverse" + ,blockcursor = style "reverse" "reverse" + ,progress = style "reverse" "reverse" } ------------------------------------------------------------------------ @@ -75,5 +73,3 @@ versinfo :: String versinfo = package ++ " v" ++ showVersion version -help :: String -help = "- curses-based MP3 player" diff --git a/Core.hs b/Core.hs --- a/Core.hs +++ b/Core.hs @@ -1,44 +1,30 @@ {-# LANGUAGE CPP, AllowAmbiguousTypes #-} --- -- Copyright (c) 2005-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. --- +-- Copyright (c) 2008, 2019-2026 Galen Huntington +-- SPDX-License-Identifier: GPL-2.0-or-later -- -- | Main module. -- module Core ( - start, - shutdown, - seekLeft, seekRight, up, down, pause, nextMode, playNext, playPrev, - forcePause, quit, putmsg, clrmsg, toggleHelp, play, playCur, - jumpToPlaying, jump, jumpRel, - upPage, downPage, - seekStart, - blacklist, - showHist, hideHist, - jumpToMatch, jumpToMatchFile, - toggleFocus, jumpToNextDir, jumpToPrevDir, - loadConfig, - discardErrors, - toggleExit, - ) where + Options(..), + start, + shutdown, + seekLeft, seekRight, upOne, downOne, pause, nextMode, playNext, playPrev, + forcePause, putmsg, clrmsg, toggleHelp, play, playCur, + jumpToPlaying, jump, jumpRel, + upPage, downPage, + seekStart, + blacklist, + showHist, hideHist, + jumpToMatchDir, jumpToMatchFile, + toggleFocus, jumpToNextDir, jumpToPrevDir, + loadConfig, + discardErrors, + toggleExit, + showTimeDiff_, +) where import Base @@ -46,25 +32,26 @@ import Lexer (parser) import State import Style -import FastIO (send, FiltHandle(..), newFiltHandle) +import FastIO (FiltHandle(..), newFiltHandle) import Tree hiding (File, Dir) import qualified Tree (File,Dir) import qualified UI import Text.Regex.PCRE.Light -import {-# SOURCE #-} Keymap (keymap) +import {-# SOURCE #-} Keymap (keyLoop) import qualified Data.ByteString.Char8 as P -import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.Sequence as Seq import Data.Array ((!), bounds, Array) +import Data.Tuple (swap) +import Control.Monad.State.Strict import System.Directory (doesFileExist, findExecutable, createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..)) import System.IO (hPutStrLn, hGetLine, stderr, hFlush) import System.Process (runInteractiveProcess, waitForProcess) import System.Clock (TimeSpec(..), diffTimeSpec) -import System.Random (randomIO) +import System.Random (randomR) import System.FilePath (()) import System.Posix.Process (exitImmediately) @@ -80,59 +67,59 @@ ------------------------------------------------------------------------ -start :: Bool -> Tree -> IO () -start playNow (Tree ds fs) = handle @SomeException (shutdown . Just . show) do +-- | Command-line configuration. +data Options = Options + { optPaused :: !Bool -- ^ start in a paused state + , optConfigPath :: !(Maybe FilePath) -- ^ override the style.conf location + } - t0 <- forkIO mpgLoop -- start this off early, to give mpg123 time to settle +start :: Options -> Tree -> IO () +start opts (Tree ds fs) = handle @SomeException (shutdown . Just . show) do c <- UI.start -- initialise curses now <- getMonoTime mode <- readState - -- fork some threads - t1 <- forkIO $ mpgInput readf - t2 <- forkIO refreshLoop - t3 <- forkIO clockLoop - t4 <- forkIO uptimeLoop - t5 <- forkIO + threads <- traverse forkIO + [ mpgLoop + , mpgInput readf + , refreshLoop + , clockLoop + , uptimeLoop -- mpg321 uses stderr for @F messages - $ if mp3Tool == "mpg321" then mpgInput errh else errorLoop + , if mp3Tool == "mpg321" then mpgInput errh else errorLoop + ] - silentlyModifyST $ \s -> s + silentlyModifyHS $ \st -> st { music = fs , folders = ds , size = 1 + (snd . bounds $ fs) , cursor = 0 , current = 0 , mode = mode - , uptime = showTimeDiff now now , boottime = now , config = c - , threads = [t0,t1,t2,t3,t4,t5] } + , configPath = optConfigPath opts + , threads } loadConfig - when (0 <= (snd . bounds $ fs)) do - if mode == Random then modifySTM jumpToRandom else playCur - when (not playNow) pause + if mode == Random then runPlayOp playRandomOp else playCur + when (optPaused opts) pause run -- won't restart if this fails! ------------------------------------------------------------------------ --- | Uniform loop and thread handler (subtle, and requires exitImmediately) +-- | Uniform loop and thread handler runForever :: IO () -> IO () -runForever fn = catch (forever fn) handler - where - handler :: SomeException -> IO () - handler e = - unless (exitTime e) $ - (warnA . show) e >> runForever fn -- reopen the catch - --- | Standard combinator. -whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenJust mb f = maybe (pure ()) f mb +runForever fn = catch (forever fn) handler where + handler :: SomeException -> IO () + handler e = unless (exitTime e) do + warnA $ "outer: " ++ show e + threadDelay 50_000 + runForever fn -- | Generic handler -- I don't know why these are ignored, but preserving old logic. @@ -157,37 +144,39 @@ mpgLoop = runForever do mmpg <- findExecutable mp3Tool case mmpg of - Nothing -> quit (Just $ "Cannot find " ++ mp3Tool ++ " in path") + Nothing -> shutdown $ Just $ "Cannot find " ++ mp3Tool ++ " in path" Just mppath -> do + mv <- try $ runInteractiveProcess mppath ["-R", "-"] Nothing Nothing + case mv of + Left (ex :: SomeException) -> + warnA $ mppath ++ " failed to start; retrying: " ++ show ex - -- if we're never able to start mpg123, do something sensible - mv <- catch (pure <$> runInteractiveProcess mppath ["-R", "-"] Nothing Nothing) - (\ (e :: SomeException) -> - do warnA ("Unable to start " ++ mp3Tool ++ ": " ++ show e) - pure Nothing) + Right (writeh, r, e, pid) -> do + ct <- modifyHS $ \st -> let sp = spawns st + 1 in (st + { mpgPid = Just pid + , status = Stopped + , info = Nothing + , id3 = Nothing + , spawns = sp + }, sp) - whenJust mv \ (hw, r, e, pid) -> do + readf <- newFiltHandle r + errh <- newFiltHandle e + putMVar mpg Mpg { readf, errh, writeh } - mhw <- newMVar hw - mew <- newMVar =<< newFiltHandle e - mfilep <- newMVar =<< newFiltHandle r + when (ct > 1) $ warnA $ mp3Tool ++ " #" ++ show ct ++ ": Ready" + catch @SomeException (void $ waitForProcess pid) (const $ pure ()) - modifyST $ \st -> - st { mp3pid = Just pid - , writeh = mhw - , errh = mew - , readf = mfilep - , status = Stopped - , info = Nothing - , id3 = Nothing - } + -- Must be in this order or risk shutdown deadlock! + silentlyModifyHS $ \st -> st { mpgPid = Nothing } + void $ takeMVar mpg - catch @SomeException (void $ waitForProcess pid) (\_ -> pure ()) - stop <- getsST doNotResuscitate + stop <- getsHS doNotResuscitate when stop exitSuccess + threadDelay 1_000_000 -- let threads spit errors warnA $ "Restarting " ++ mppath ++ " ..." - -- Delay to slow spawn loops in case of trouble. + -- Slow spawn loops in case of trouble. threadDelay 4_000_000 @@ -197,7 +186,7 @@ -- for it to be modified again. refreshLoop :: IO () refreshLoop = do - mvar <- getsST modified + mvar <- getsHS modified runForever $ takeMVar mvar >> UI.refresh ------------------------------------------------------------------------ @@ -205,11 +194,9 @@ -- | The clock ticks once per minute, but check more often in case of drift. uptimeLoop :: IO () uptimeLoop = runForever $ do - threadDelay delay now <- getMonoTime - modifyST $ \st -> st { uptime = showTimeDiff (boottime st) now } - where - delay = 5 * 1000 * 1000 -- refresh every 5 seconds + modifyHS_ $ \st -> st { uptime = showTimeDiff (boottime st) now } + threadDelay 3_000_000 ------------------------------------------------------------------------ @@ -233,21 +220,16 @@ ------------------------------------------------------------------------ --- | Once each half second, wake up and redraw the clock +-- | Periodically wake up and redraw the clock clockLoop :: IO () -clockLoop = runForever $ threadDelay delay >> UI.refreshClock - where - delay = 500 * 1000 -- 0.5 second +clockLoop = runForever $ threadDelay 125_000 *> UI.refreshClock ------------------------------------------------------------------------ -- | Handle, and display errors produced by mpg123 errorLoop :: IO () -errorLoop = runForever $ do - s <- getsST errh >>= readMVar >>= hGetLine . filtHandle - if s == "No default libao driver available." - then quit $ Just $ s ++ " Perhaps another instance of hmp3 is running?" - else warnA s +errorLoop = runForever $ + readMVar mpg <&> errh >>= hGetLine . filtHandle >>= (warnA . ("mpg: " ++)) ------------------------------------------------------------------------ @@ -255,47 +237,34 @@ -- shutdown kills the other end of the pipe, hGetLine will fail, so we -- take that chance to exit. -- -mpgInput :: (HState -> MVar FiltHandle) -> IO () +mpgInput :: (Mpg -> FiltHandle) -> IO () mpgInput field = runForever $ do - mvar <- getsST field - fp <- readMVar mvar - res <- parser fp + res <- parser =<< field <$> readMVar mpg case res of Right m -> handleMsg m - Left (Just e) -> (warnA.show) e + Left (Just e) -> (warnA . ("read: " ++) . show) e _ -> pure () ------------------------------------------------------------------------ -- | The main thread: handle keystrokes fed to us by curses run :: IO () -run = runForever $ sequence_ . keymap =<< getKeys - where - -- A lazy list of curses keys - getKeys = unsafeInterleaveIO $ (:) <$> UI.getKey <*> getKeys +run = runForever keyLoop ------------------------------------------------------------------------ -- | Close most things. Important to do all the jobs: shutdown :: Maybe String -> IO () -shutdown ms = - do silentlyModifyST $ \st -> st { doNotResuscitate = True } - discardErrors writeState - withST $ \st -> do - case mp3pid st of - Nothing -> pure () - Just pid -> do - h <- readMVar (writeh st) - send h Quit -- ask politely - waitForProcess pid - pure () - - `finally` - - do isXterm <- getsST xterm - UI.end isXterm - when (isJust ms) $ hPutStrLn stderr (fromJust ms) >> hFlush stderr - exitImmediately ExitSuccess +shutdown ms = do + silentlyModifyHS $ \st -> st { doNotResuscitate = True } + discardErrors writeState + mpid <- getsHS mpgPid + flip (maybe $ pure ()) mpid \pid -> do + discardErrors $ sendMpg Quit + void $ waitForProcess pid + UI.end =<< getsHS xterm + flip (maybe $ pure ()) ms \s -> hPutStrLn stderr s *> hFlush stderr + exitImmediately ExitSuccess ------------------------------------------------------------------------ -- @@ -304,17 +273,17 @@ -- handleMsg :: Msg -> IO () handleMsg (T _) = pure () -handleMsg (I i) = modifyST $ \s -> s { info = Just i } -handleMsg (F (File (Left _))) = modifyST $ \s -> s { id3 = Nothing } -handleMsg (F (File (Right i))) = modifyST $ \s -> s { id3 = Just i } +handleMsg (I i) = modifyHS_ $ \s -> s { info = Just i } +handleMsg (F (File (Left _))) = modifyHS_ $ \s -> s { id3 = Nothing } +handleMsg (F (File (Right i))) = modifyHS_ $ \s -> s { id3 = Just i } handleMsg (S t) = do - modifyST $ \s -> s { status = t } + modifyHS_ $ \s -> s { status = t } when (t == Stopped) playNext -- transition to next song handleMsg (R f) = do - silentlyModifyST \st -> st { clock = Just f } - getsST clockUpdate >>= flip when UI.refreshClock + silentlyModifyHS \st -> st { clock = Just f } + getsHS clockUpdate >>= flip when UI.refreshClock ------------------------------------------------------------------------ -- @@ -336,146 +305,147 @@ -- | Generic seek seek :: (Frame -> Int) -> IO () seek fn = do - f <- getsST clock + f <- getsHS clock case f of Nothing -> pure () Just g -> do - withST $ \st -> do - h <- readMVar (writeh st) - send h $ Jump (fn g) - forceNextPacket -- don't drop the next Frame. - silentlyModifyST $ \st -> st { clockUpdate = True } + sendMpg $ Jump (fn g) + forceNextPacket -- don't drop the next Frame. + silentlyModifyHS $ \st -> st { clockUpdate = True } + +------------------------------------------------------------------------ + +-- | Generic jump +jumpFn :: (Int -> Int) -> IO () +jumpFn fn = modifyHS_ \st -> + st { cursor = (fn (cursor st) `min` (size st - 1)) `max` 0 } + +-- | Move cursor up or down +upOne, downOne :: IO () +upOne = jumpFn (subtract 1) +downOne = jumpFn (+1) + page :: Int -> IO () page dir = do (sz, _) <- UI.screenSize - modifySTM $ flip jumpTo (+ dir*(sz-5)) + jumpFn (+ dir*(sz-5)) + upPage, downPage :: IO () upPage = page (-1) downPage = page ( 1) - ------------------------------------------------------------------------- - --- | Move cursor up or down -up, down :: IO () -up = modifySTM $ flip jumpTo (subtract 1) -down = modifySTM $ flip jumpTo (+1) - -- | Move cursor to specified index jump :: Int -> IO () -jump i = modifySTM $ flip jumpTo (const i) +jump = jumpFn . const -- | Jump to relative place, 0 to 1. jumpRel :: Float -> IO () jumpRel r | r < 0 || r >= 1 = pure () - | True = modifySTM \st -> - pure st { cursor = floor $ fromIntegral (size st) * r } + | True = modifyHS_ $ \st -> + st { cursor = floor $ fromIntegral (size st) * r } --- | Generic jump --- TODO why is this in IO? -jumpTo :: HState -> (Int -> Int) -> IO HState -jumpTo st fn = do - let l = max 0 (size st - 1) - i = fn (cursor st) - n | i > l = l - | i < 0 = 0 - | True = i - pure st { cursor = n } +-- | Experimental feature concept. +blacklist :: IO () +blacklist = do + st <- getsHS id + appendFile ".hmp3-delete" . (++"\n") . P.unpack $ + let fe = music st ! cursor st + in P.intercalate (P.singleton '/') [dname $ folders st ! fdir fe, fbase fe] ------------------------------------------------------------------------ --- | Load and play the song under the cursor +-- | Operates on HState and outputs maybe a track to play. +type PlayOp = State HState (Maybe Int) + +-- | Play the song under the cursor or random if that one is playing +-- TODO these semantics are strange; maybe playNext instead of random? play :: IO () -play = modifySTM $ \st -> - if current st == cursor st - then jumpToRandom st - else playAtN st (const $ cursor st) +play = runPlayOp do + HState { current, cursor } <- get + if current == cursor + then playRandomOp + else pure $ Just cursor +-- | Play the song under the cursor (from the start) playCur :: IO () -playCur = modifySTM $ \st -> playAtN st (const $ cursor st) - -blacklist :: IO () -blacklist = do - st <- getsST id - appendFile ".hmp3-delete" . (++"\n") . P.unpack $ - let fe = music st ! cursor st - in P.intercalate (P.singleton '/') [dname $ folders st ! fdir fe, fbase fe] - --- | Jump to a random song -jumpToRandom :: HState -> IO HState -jumpToRandom st = do - n' <- randomIO - let n = abs n' `mod` (size st - 1) - playAtN st (const n) +playCur = runPlayOp $ Just <$> gets cursor -- | Play the song before the current song, if we're not at the beginning -- If we're at the beginning, and loop mode is on, then loop to the end -- If we're in random mode, play the next random track playPrev :: IO () -playPrev = modifySTM \st -> case mode st of - Random -> jumpToRandom st - Single -> pure st - _ | current st > 0 - -> playAtN st (subtract 1) - Loop -> playAtN st (const (size st - 1)) - Once -> pure st +playPrev = runPlayOp do + HState { mode, size, current } <- get + case mode of + Random -> playRandomOp + Single -> pure Nothing + _ | current > 0 + -> pure $ Just $ current - 1 + Loop -> pure $ Just $ size - 1 + Once -> pure Nothing -- | Play the song following the current song, if we're not at the end -- If we're at the end, and loop mode is on, then loop to the start -- If we're in random mode, play the next random track playNext :: IO () -playNext = modifySTM \st -> case mode st of - Random -> jumpToRandom st - Single -> pure st - _ | current st < size st - 1 - -> playAtN st (+ 1) - Loop -> playAtN st (const 0) - Once -> pure st +playNext = runPlayOp do + HState { mode, current, size } <- get + let next = current + 1 + case mode of + Random -> playRandomOp + Single -> pure Nothing + _ | next < size + -> pure $ Just next + Loop -> pure $ Just 0 + Once -> pure Nothing +-- | Random song +playRandomOp :: PlayOp +playRandomOp = do + HState { size, randomGen } <- get + let (new, gen') = randomR (0, size-1) randomGen + modify' \st -> st { randomGen = gen' } + pure $ Just new + -- | Generic next song selection --- If the cursor and current are currently the same, continue that. -playAtN :: HState -> (Int -> Int) -> IO HState -playAtN st fn = do +-- If cursor is on current, drag it along. +runPlayOp :: PlayOp -> IO () +runPlayOp op = do now <- getMonoTime - let m = music st - i = current st - new = fn i - fe = m ! new - -- unsure of this GBH (2008) - f = P.intercalate (P.singleton '/') - [dname $ folders st ! fdir fe, fbase fe] - j = cursor st - st' = st { current = new - , status = Playing - , cursor = if i == cursor st then new else j - , playHist = Seq.take 36 $ (now, new) Seq.<| playHist st - } - h <- readMVar (writeh st) - send h (Load f) - pure st' + mfile <- modifyHS $ swap . runState do + mnew <- op + forM mnew \new -> do + HState { .. } <- get + let fe = music ! new + f = P.intercalate (P.singleton '/') + [dname $ folders ! fdir fe, fbase fe] + modify' \st -> st + { current = new + , status = Playing + , cursor = if current == cursor then new else cursor + , playHist = Seq.take 36 $ (now, new) Seq.<| playHist + } + pure f + forM_ mfile $ sendMpg . Load ------------------------------------------------------------------------ -- | Toggle pause on the current song pause :: IO () -pause = withST $ \st -> readMVar (writeh st) >>= flip send Pause +pause = sendMpg Pause -- | Always pause forcePause :: IO () forcePause = do - st <- getsST status + st <- getsHS status when (st == Playing) pause --- | Shutdown and exit -quit :: Maybe String -> IO () -quit = shutdown - ------------------------------------------------------------------------ -- | Move cursor to currently playing song jumpToPlaying :: IO () -jumpToPlaying = modifyST $ \st -> st { cursor = current st } +jumpToPlaying = modifyHS_ $ \st -> st { cursor = current st } -- | Move cursor to first song in next directory (or wrap) jumpToNextDir, jumpToPrevDir :: IO () @@ -484,7 +454,7 @@ -- | Generic jump to dir jumpToDir :: (Int -> Int -> Int) -> IO () -jumpToDir fn = modifyST $ \st -> if size st == 0 then st else +jumpToDir fn = modifyHS_ $ \st -> if size st == 0 then st else let i = fdir (music st ! cursor st) len = 1 + (snd . bounds $ folders st) d = fn i len @@ -505,8 +475,8 @@ where k st = (music st, if size st == 0 then -1 else cursor st, size st) sel i _ = i -jumpToMatch :: Maybe String -> Bool -> IO () -jumpToMatch re sw = genericJumpToMatch re sw k sel +jumpToMatchDir :: Maybe String -> Bool -> IO () +jumpToMatchDir re sw = genericJumpToMatch re sw k sel where k st = (folders st , if size st == 0 then -1 else fdir (music st ! cursor st) , 1 + (snd . bounds $ folders st)) @@ -520,80 +490,56 @@ -> IO () genericJumpToMatch re sw k sel = do - found <- modifySTM_ $ \st -> do + found <- modifyHS $ \st -> do let mre = case re of - -- work out if we have no pattern, a cached pattern, or a new pattern - Nothing -> case regex st of - Nothing -> Nothing - Just (r,d) -> Just (r,d==sw) - Just s -> case compileM (P.pack s) [caseless,utf8] of - Left _ -> Nothing - Right v -> Just (v,sw) - case mre of - Nothing -> pure (st,False) -- no pattern - Just (p,forwards) -> do - - let (fs,cur,m) = k st - -{- - loop fn inc n - | fn n = pure Nothing - | otherwise = do - let s = extract (fs ! n) - case match p s [] of - Nothing -> loop fn inc $! inc n --} - - check n = let s = extract (fs ! n) in - case match p s [] of - Nothing -> pure Nothing - Just _ -> pure $ Just n - - -- mi <- if forwards then loop (>=m) (+1) (cur+1) - -- else loop (<0) (subtract 1) (cur-1) - mi <- fmap msum $ traverse check $ - if forwards then [cur+1..m-1] ++ [0..cur] - else [cur-1,cur-2..0] ++ [m-1,m-2..cur] - - - let st' = st { regex = Just (p,forwards==sw) } - pure case mi of - Nothing -> (st',False) - Just i -> (st' { cursor = sel i st }, True) + Nothing -> case regex st of + Nothing -> Nothing + Just (r, d) -> Just (r, d==sw) + Just s -> case compileM (P.pack s) [caseless, utf8] of + Left _ -> Nothing + Right v -> Just (v, sw) + flip (maybe (st, False)) mre \ (p, forwards) -> do + let (fs, cur, m) = k st + l = if forwards then [cur+1..m-1] ++ [0..cur] + else [cur-1,cur-2..0] ++ [m-1,m-2..cur] + st' = st { regex = Just (p, forwards==sw) } + case [ i | i <- l, isJust $ match p (extract (fs ! i)) [] ] of + i:_ -> (st' { cursor = sel i st }, True) + _ -> (st', False) - unless found $ putmsg (Fast "No match found." defaultSty) *> touchST + unless found $ putmsg (Fast "No match found." defaultSty) *> touchHS ------------------------------------------------------------------------ -- | Show/hide the help window toggleHelp :: IO () -toggleHelp = modifyST $ \st -> st { helpVisible = not (helpVisible st) } +toggleHelp = modifyHS_ $ \st -> st { helpVisible = not (helpVisible st) } -- | Focus the minibuffer toggleFocus :: IO () -toggleFocus = modifyST $ \st -> st { miniFocused = not (miniFocused st) } +toggleFocus = modifyHS_ $ \st -> st { miniFocused = not (miniFocused st) } -- | Show/hide the confirm exit modal toggleExit :: IO () -toggleExit = modifyST $ \st -> st { exitVisible = not (exitVisible st) } +toggleExit = modifyHS_ $ \st -> st { exitVisible = not (exitVisible st) } -- | History on or off hideHist :: IO () -hideHist = modifyST $ \st -> st { histVisible = Nothing } +hideHist = modifyHS_ $ \st -> st { histVisible = Nothing } + showHist :: IO () showHist = do now <- getMonoTime - modifyST $ \st -> st { + modifyHS_ $ \st -> st { helpVisible = False, histVisible = Just $ do (tm, ix) <- toList $ playHist st - pure (UTF8.toString $ showTimeDiff_ True tm now - , (ix, UTF8.toString $ fbase $ music st ! ix)) + pure (showTimeDiff_ True tm now, (ix, fbase $ music st ! ix)) } -- | Toggle the mode flag nextMode :: IO () -nextMode = modifyST $ \st -> st { mode = next (mode st) } +nextMode = modifyHS_ $ \st -> st { mode = next (mode st) } where next v = if v == maxBound then minBound else succ v @@ -607,7 +553,7 @@ writeState = do dir <- getStatePath createDirectoryIfMissing True dir - mode <- getsST mode + mode <- getsHS mode writeFile (dir "mode") $ show mode ++ "\n" -- | Read mode state @@ -619,7 +565,7 @@ modeM <- if b then readMaybe <$!> readFile f else pure Nothing - pure $ fromMaybe (mode emptySt) modeM + pure $ fromMaybe minBound modeM ------------------------------------------------------------------------ -- Read styles from style.conf @@ -630,7 +576,7 @@ loadConfig :: IO () loadConfig = do - f <- getConfPath + f <- maybe getConfPath pure =<< getsHS configPath b <- doesFileExist f if b then do str' <- readFile f @@ -646,18 +592,17 @@ Just rsty -> do let sty = buildStyle rsty initcolours sty - modifyST $ \st -> st { config = sty } - else do - let sty = config emptySt - initcolours sty - modifyST $ \st -> st { config = sty } + modifyHS_ $ \st -> st { config = sty } + else + pure () -- TODO in some cases show a warning UI.resetui ------------------------------------------------------------------------ -- Editing the minibuffer +-- TODO maybe shouldn't be silent? putmsg :: StringA -> IO () -putmsg s = silentlyModifyST $ \st -> st { minibuffer = s } +putmsg s = silentlyModifyHS $ \st -> st { minibuffer = s } -- | Modify without triggering a refresh clrmsg :: IO () @@ -666,6 +611,7 @@ -- warnA :: String -> IO () warnA x = do - sty <- getsST config + sty <- getsHS config putmsg $ Fast (P.pack x) (warnings sty) + touchHS diff --git a/FastIO.hs b/FastIO.hs --- a/FastIO.hs +++ b/FastIO.hs @@ -1,22 +1,6 @@ --- -- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons --- Copyright (c) 2019, 2020 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. --- +-- Copyright (c) 2019-2021, 2025 Galen Huntington +-- SPDX-License-Identifier: GPL-2.0-or-later -- | ByteString versions of some common IO functions @@ -24,15 +8,11 @@ import Base -import Syntax (Pretty(ppr)) - import qualified Data.ByteString.Char8 as B import System.Posix.Files.ByteString import System.Posix.Directory.ByteString -import System.IO (hFlush) - ------------------------------------------------------------------------ -- Use every nth frame. 1 for no dropping. @@ -99,11 +79,6 @@ isReadable :: ByteString -> IO Bool isReadable fp = fileAccess fp True False False - --- --------------------------------------------------------------------- --- | Send a msg over the channel to the decoder -send :: Pretty a => Handle -> a -> IO () -send h m = B.hPut h (ppr m) >> B.hPut h "\n" >> hFlush h ------------------------------------------------------------------------ diff --git a/Keymap.hs b/Keymap.hs --- a/Keymap.hs +++ b/Keymap.hs @@ -1,304 +1,219 @@ --- +{-# OPTIONS -Wno-orphans #-} + -- 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. --- +-- Copyright (c) 2008, 2019-2026 Galen Huntington +-- SPDX-License-Identifier: GPL-2.0-or-later -- --- | Keymap manipulation --- --- The idea of using lazy lexers to implement keymaps is described in --- the paper: +-- | Keymap manipulation. -- --- > 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. +-- Each "mode" of the keymap is a 'KeyMap': a closure that consumes one +-- keystroke and returns the 'KeyMap' to use for the next one. Modal +-- transitions (entering search, popping up the song-history modal, +-- confirming a quit) are just "return a different 'KeyMap'." -- -module Keymap where +module Keymap (keyLoop, keyTable, unkey, charToKey) where -import Prelude () -import Base hiding (all, delete, (!?)) +import Base hiding ((!?)) import Core import Config (package) -import State (getsST, touchST, HState(helpVisible, histVisible)) +import State (getsHS, touchHS, modifyHS_, HState(histVisible, searchHist)) import Style (defaultSty, StringA(Fast)) -import qualified UI (resetui) -import Lexers ((>||<),action,meta,execLexer - ,alt,with,char,Regexp,Lexer) +import qualified UI (getKey, resetui) import UI.HSCurses.Curses (Key(..), decodeKey) import qualified Data.ByteString.Char8 as P -import qualified Data.Map as M +import qualified Data.Map.Strict as M -data Direction = Forwards | Backwards deriving stock Eq -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 driver --- --- The keymap --- -keymap :: [Char] -> [IO ()] -keymap cs = map (clrmsg *>) actions - where (actions,_,_) = execLexer allKeys (cs, SearchState [] undefined) +-- | A 'KeyMap' handles the next keystroke and produces the 'KeyMap' to +-- use thereafter. +newtype KeyMap = KeyMap (Char -> IO KeyMap) -allKeys :: LexerS -allKeys = commands >||< search >||< history >||< confirmQuit +-- | Read keys forever and dispatch. Each round clears the minibuffer +-- between the keystroke and the action so messages from the previous +-- action remain visible until the user reacts. +keyLoop :: IO () +keyLoop = go mainMode where + go (KeyMap f) = UI.getKey >>= \c -> clrmsg *> f c >>= go -commands :: LexerS -commands = alt keys `action` \[c] -> Just $ fromMaybe (pure ()) $ M.lookup c keyMap ------------------------------------------------------------------------ +-- Top-level normal mode -search :: LexerS -search = searchDirs >||< searchFiles +mainMode :: KeyMap +mainMode = KeyMap dispatch where + dispatch 'q' = forcePause *> toggleExit *> touchHS $> confirmQuitMode + dispatch c + | c `elem` ['/', '?', '\\', '|'] + = enterSearch c + | c `elem` ['H', ';'] = showHist *> touchHS $> historyMode + | c >= '1' && c <= '9' = + jumpRel (0.1 * fromIntegral (fromEnum c - 48)) $> mainMode + | True = sequence_ (M.lookup c keyMap) $> mainMode -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) + enterSearch stype = do + toggleFocus + hist <- getsHS searchHist + searchMode stype $ Zipper "" hist [] -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) +------------------------------------------------------------------------ +-- Search mode --- "lens" -zipEdit :: (String -> String) -> Zipper -> Zipper -zipEdit f zipp = zipp{cur = f $ cur zipp} +-- | Zipper over the search-history list, with the currently edited +-- string in the focus. 'back' holds older entries we can step back +-- to (Up); 'front' holds entries we've stepped back from (Down). +data Zipper = Zipper { cur :: !String, _back :: ![String], _front :: ![String] } -printSearch :: SearchSpec -> Maybe (Either a (IO ())) -printSearch spec = with do - putmsg $ Fast (P.pack $ schChar (schType spec) : cur (schZipper spec)) defaultSty - touchST +searchMode :: Char -> Zipper -> IO KeyMap +searchMode stype = step where + step z = renderSearch stype z $> KeyMap (`dispatch` z) -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) + dispatch c z + | c == '\ESC' = clrmsg *> touchHS *> leave + | c `elem` enter' = commit z + | c `elem` delete' = step $ zipEdit dropLast z + | k == KeyUp = step $ zipUp z + | k == KeyDown = step $ zipDown z + | k == KeyDC = histDelete z + | c > '\255' = step z -- ignore other special keys + | otherwise = step $ zipEdit (++ [c]) z + where k = charToKey c -search_char :: LexerS -search_char = anyNonSpecial `meta` \c -> updateSearch $ zipEdit (++ c) - where anyNonSpecial = alt $ any' \\ (enter' ++ delete' ++ ['\ESC']) + commit (Zipper [] _ _) = clrmsg *> touchHS *> leave + commit (Zipper pat _ _) = do + let jumpy = if stype `elem` ['/', '?'] + then jumpToMatchFile else jumpToMatchDir + jumpy (Just pat) (stype `elem` ['/', '\\']) + modifyHS_ \st -> st { searchHist = pat : filter (/= pat) (searchHist st) } + leave -search_bs :: LexerS -search_bs = delete `meta` - \_ -> updateSearch $ zipEdit \case [] -> []; xs -> init xs + histDelete z = do + let z' = case z of + Zipper _ b (pv:rest) -> Zipper pv b rest + Zipper _ b _ -> Zipper "" b [] + modifyHS_ \st -> st { searchHist = filter (/= cur z) (searchHist st) } + step z' -search_up :: LexerS -search_up = char (unkey KeyUp) `meta` \_ -> updateSearch \case - Zipper cur (nx:rest) front -> Zipper nx rest (cur:front) - zipp -> zipp + leave = toggleFocus $> mainMode -search_down :: LexerS -search_down = char (unkey KeyDown) `meta` \_ -> updateSearch \case - Zipper cur back (pv:rest) -> Zipper pv (cur:back) rest - zipp -> zipp +renderSearch :: Char -> Zipper -> IO () +renderSearch prefix z = do + putmsg $ Fast (P.pack (prefix : cur z)) defaultSty + touchHS -search_del :: LexerS -search_del = char (unkey KeyDC) `meta` \_ sst -> let - (r, sst', ml) = flip updateSearch sst \case - Zipper _ back (pv:rest) -> Zipper pv back rest - Zipper _ back _ -> Zipper "" back [] - newhist = let Zipper cur _ _ = schZipper $ schSpec sst - in filter (/=cur) $ schHist sst - in (r, sst'{schHist = newhist}, ml) +dropLast :: [a] -> [a] +dropLast [] = [] +dropLast xs = init xs -search_esc :: LexerS -search_esc = char '\ESC' `meta` - \_ (SearchState hist _) -> endSearchWith (clrmsg *> touchST) hist +zipEdit :: (String -> String) -> Zipper -> Zipper +zipEdit f z = z { cur = f (cur z) } -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) (schDir typ == Forwards) - do pat : filter (/= pat) hist +zipUp, zipDown :: Zipper -> Zipper +zipUp (Zipper c (nx:rest) f) = Zipper nx rest (c:f) +zipUp z = z +zipDown (Zipper c b (pv:rest)) = Zipper pv (c:b) rest +zipDown z = z ------------------------------------------------------------------------ +-- Song-history popup -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 - ) +historyMode :: KeyMap +historyMode = KeyMap \c -> do + for_ (M.lookup c historyKeys) \k -> do + phm <- getsHS histVisible + for_ (phm >>= (!? k)) (jump . fst . snd) + hideHist + touchHS + pure mainMode + where + historyKeys :: M.Map Char Int + historyKeys = M.fromList $ zip (['0'..'9'] ++ ['a'..'z']) [0..] + -- Compatibility: List.!? only added in GHC 9.8 xs !? n = listToMaybe $ drop n xs + ------------------------------------------------------------------------ +-- Confirm-quit modal -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)) +confirmQuitMode :: KeyMap +confirmQuitMode = KeyMap \case + 'y' -> shutdown Nothing $> undefined -- shutdown never returns + _ -> toggleExit *> touchHS $> mainMode + ------------------------------------------------------------------------ +-- Char ↔ Key translation +-- +-- ncurses delivers special keys as integer codes ≥ 256; for everything +-- in 0..255 'decodeKey' returns 'KeyChar (chr n)'. We keep working in +-- 'Char' (UI.getKey's type), so we extend the range up to '\500' to +-- cover the named keys we actually use (KEY_RESIZE is around 410). --- "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']] +keyCharMap = M.fromList [(charToKey c, c) | c <- ['\0' .. '\500']] 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'] +enter', delete' :: [Char] +enter' = ['\n', '\r'] +delete' = ['\BS', '\DEL', unkey KeyBackspace] -delete, enter :: Regexp SearchState (IO ()) -delete = alt delete' -enter = alt enter' ------------------------------------------------------------------------ +-- The keymap with help descriptions and actions. --- --- 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, loop, and single 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) + [ ("Move up", ['k',unkey KeyUp], upOne) + , ("Move down", ['j',unkey KeyDown], downOne) + , ("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'], placeholder) + , ("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, loop, and single 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) + , ("Toggle the song history", ['H', ';'], placeholder) + , ("Search for file matching regex", ['/'], placeholder) + , ("Search backwards for file", ['?'], placeholder) + , ("Search for directory matching regex", ['\\'], placeholder) + , ("Search backwards for directory", ['|'], placeholder) + , ("Quit " ++ package, ['q'], placeholder) ] - -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 + where placeholder = pure () -- handled separately +-- Compiled dispatch table for normal-mode single-key commands. keyMap :: M.Map Char (IO ()) -keyMap = M.fromList $ [ (c,a) | (_,cs,a) <- keyTable, c <- cs ] ++ innerTable +keyMap = M.fromList [ (c, a) | (_, cs, a) <- keyTable, c <- cs ] -keys :: [Char] -keys = concat [ cs | (_,cs,_) <- keyTable ] ++ map fst innerTable diff --git a/Keymap.hs-boot b/Keymap.hs-boot --- a/Keymap.hs-boot +++ b/Keymap.hs-boot @@ -2,9 +2,9 @@ import UI.HSCurses.Curses (Key) -keymap :: [Char] -> [IO ()] +keyLoop :: IO () keyTable :: [(String, [Char], IO ())] -extraTable :: [(String, [Char])] unkey :: Key -> Char charToKey :: Char -> Key + diff --git a/Lexer.hs b/Lexer.hs --- a/Lexer.hs +++ b/Lexer.hs @@ -1,26 +1,10 @@ --- -- Copyright (c) 2005-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. --- +-- Copyright (c) 2008, 2019-2026 Galen Huntington +-- SPDX-License-Identifier: GPL-2.0-or-later -- Lexer for mpg123 messages -module Lexer ( parser ) where +module Lexer ( parser, doP, doF, doS, doI ) where import Base @@ -34,22 +18,19 @@ ------------------------------------------------------------------------ -pSafeHead :: ByteString -> Char -pSafeHead s = if P.null s then ' ' else P.head s - readPS :: ByteString -> Int readPS = fst . fromJust . P.readInt doP :: ByteString -> Msg -doP s = S case pSafeHead s of - '0' -> Stopped - '1' -> Paused - '2' -> Playing - -- mpg123 outputs this but then @P 0 causing double Plays - -- (I think old mpg123 didn't do @P 0 so I added this) - -- '3' -> Stopped -- used by mpg123 for end of song - _ -> Playing - -- _ -> error "Invalid Status" +doP s = S case fst <$> P.uncons s of + Just '0' -> Stopped + Just '1' -> Paused + Just '2' -> Playing + -- mpg123 outputs this but then @P 0 causing double Plays + -- (I think old mpg123 didn't do @P 0 so I added this) + -- '3' -> Stopped -- used by mpg123 for end of song + _ -> Playing + -- _ -> error "Invalid Status" -- Frame decoding status updates (once per frame). doF :: ByteString -> Msg diff --git a/Lexers.hs b/Lexers.hs deleted file mode 100644 --- a/Lexers.hs +++ /dev/null @@ -1,552 +0,0 @@ --- Compiler Toolkit: Self-optimizing lexers --- --- Author : Manuel M. T. Chakravarty --- Created: 24 February 95, 2 March 99 --- --- Version $Revision: 1.1 $ from $Date: 2002/07/28 03:35:20 $ --- --- Copyright (c) [1995..2000] Manuel M. T. Chakravarty --- Copyright (c) 2004-2008 Don Stewart --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Library General Public --- License as published by the Free Software Foundation; either --- version 2 of the License, or (at your option) any later version. --- --- This library 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 --- Library General Public License for more details. --- ---- DESCRIPTION --------------------------------------------------------------- --- --- Self-optimizing lexer combinators. --- --- For detailed information, see ``Lazy Lexing is Fast'', Manuel --- M. T. Chakravarty, in A. Middeldorp and T. Sato, editors, Proceedings of --- Fourth Fuji International Symposium on Functional and Logic Programming, --- Springer-Verlag, LNCS 1722, 1999. (See my Web page for details.) --- --- http://www.cse.unsw.edu.au/~chak/papers/Cha99.html --- --- Thanks to Simon L. Peyton Jones and Roman --- Lechtchinsky for their helpful suggestions that --- improved the design of this library. --- ---- DOCU ---------------------------------------------------------------------- --- --- language: Haskell 98 --- --- The idea is to combine the benefits of off-line generators with --- combinators like in `Parsers.hs' (which builds on Swierstra/Duponcheel's --- technique for self-optimizing parser combinators). In essence, a state --- transition graph representing a lexer table is computed on the fly, to --- make lexing deterministic and based on cheap table lookups. --- --- Regular expression map to Haskell expressions as follows. If `x' and `y' --- are regular expressions, --- --- -> epsilon --- xy -> x +> y --- x*y -> x `star` y --- x+y -> x `plus` y --- x?y -> x `quest` y --- --- Given such a Haskelized regular expression `hre', we can use --- --- (1) hre `lexaction` \lexeme -> Nothing --- (2) hre `lexaction` \lexeme -> Just token --- (3) hre `lexmeta` \lexeme pos s -> (res, pos', s', Nothing) --- (4) hre `lexmeta` \lexeme pos s -> (res, pos', s', Just l) --- --- where `epsilon' is required at the end of `hre' if it otherwise ends on --- `star', `plus', or `quest', and then, we have --- --- (1) discards `lexeme' accepted by `hre', --- (2) turns the `lexeme' accepted by `hre' into a token, --- (3) while discarding the lexeme accepted by `hre', transforms the --- position and/or user state, and --- (4) while discarding the lexeme accepted by `hre', transforms the --- position and/or user state and returns a lexer to be used for the --- next lexeme. --- --- The component `res' in case of a meta action, can be `Nothing', `Just --- (Left err)', or `Just (Right token)' to return nothing, an error, or a --- token from a meta action, respectively. --- --- * This module makes essential use of graphical data structures (for --- representing the state transition graph) and laziness (for maintaining --- the last action in `execLexer'. --- --- NOTES: --- --- * In this implementation, the combinators `quest`, `star`, and `plus` are --- *right* associative - this was different in the ``Lazy Lexing is Fast'' --- paper. This change was made on a suggestion by Martin Norbäck --- . --- ---- TODO ---------------------------------------------------------------------- --- --- * error correction is missing --- --- * in (>||<) in the last case, `(addBoundsNum bn bn')' is too simple, as --- the number of outgoing edges is not the sum of the numbers of the --- individual states when there are conflicting edges, ie, ones labeled --- with the same character; however, the number is only used to decide a --- heuristic, so it is questionable whether it is worth spending the --- additional effort of computing the accurate number --- --- * Unicode posses a problem as the character domain becomes too big for --- using arrays to represent transition tables and even sparse structures --- will posse a significant overhead when character ranges are naively --- represented. So, it might be time for finite maps again. --- --- Regarding the character ranges, there seem to be at least two --- possibilities. Doaitse explicitly uses ranges and avoids expanding --- them. The problem with this approach is that we may only have --- predicates such as `isAlphaNum' to determine whether a givne character --- belongs to some character class. From this representation it is --- difficult to efficiently compute a range. The second approach, as --- proposed by Tom Pledger (on the Haskell list) --- would be to actually use predicates directly and make the whole business --- efficient by caching predicate queries. In other words, for any given --- character after we have determined (in a given state) once what the --- following state on accepting that character is, we need not consult the --- predicates again if we memorise the successor state the first time --- around. --- - -module Lexers ( - - Regexp, Lexer, Action, Meta, Error, - epsilon, char, (+>), - lexaction, lexactionErr, lexmeta, action, meta, - (>|<), (>||<), - star, plus, quest, alt, string, with, LexerState, execLexer - - ) where - -import Prelude hiding (last) -import Data.Maybe (fromMaybe) -import Data.Array (Array, (!), assocs, accumArray) - -infixr 4 `quest`, `star`, `plus` -infixl 3 +>, `lexaction`, `lexmeta`, `action`, `meta` -infixl 2 >|<, >||< - --- constants --- --------- - --- we use the dense representation if a table has at least the given number of --- (non-error) elements --- -denseMin :: Int -denseMin = 20 - - --- data structures --- --------------- - --- represents the number of (non-error) elements and the bounds of a table --- -type BoundsNum = (Int, Char, Char) - --- empty bounds --- --- nullBoundsNum :: BoundsNum --- nullBoundsNum = (0, maxBound, minBound) - --- combine two bounds --- -addBoundsNum :: BoundsNum -> BoundsNum -> BoundsNum -addBoundsNum (n, lc, hc) (n', lc', hc') = (n + n', min lc lc', max hc hc') - --- check whether a character is in the bounds --- -inBounds :: Char -> BoundsNum -> Bool -inBounds c (_, lc, hc) = c >= lc && c <= hc - --- Lexer errors -type Error = String - --- Lexical actions take a lexeme with its position and may return a token; in --- a variant, an error can be returned (EXPORTED) --- --- * if there is no token returned, the current lexeme is discarded lexing --- continues looking for a token --- -type Action t = String -> Maybe t -type ActionErr t = String -> Either Error t - --- Meta actions transform the lexeme, and a user-defined state; they --- may return a lexer, which is then used for accepting the next token --- (this is important to implement non-regular behaviour like nested --- comments) (EXPORTED) --- -type Meta s t = String -> s -> (Maybe (Either Error t), -- err/tok? - s, -- state - Maybe (Lexer s t)) -- lexer? - --- tree structure used to represent the lexer table (EXPORTED ABSTRACTLY) --- --- * each node in the tree corresponds to a state of the lexer; the associated --- actions are those that apply when the corresponding state is reached --- -data Lexer s t = Lexer (LexAction s t) (Cont s t) - --- represent the continuation of a lexer --- -data Cont s t = -- on top of the tree, where entries are dense, we use arrays - -- - Dense BoundsNum (Array Char (Lexer s t)) - -- - -- further down, where the valid entries are sparse, we - -- use association lists, to save memory (the first argument - -- is the length of the list) - -- - | Sparse BoundsNum [(Char, Lexer s t)] - -- - -- end of a automaton - -- - | Done - --- lexical action (EXPORTED ABSTRACTLY) --- -data LexAction s t = Action (Meta s t) - | NoAction - --- a regular expression (EXPORTED) --- -type Regexp s t = Lexer s t -> Lexer s t - - --- basic combinators --- ----------------- - --- Empty lexeme (EXPORTED) --- -epsilon :: Regexp s t -epsilon = id - --- One character regexp (EXPORTED) --- -char :: Char -> Regexp s t -char c = \l -> Lexer NoAction (Sparse (1, c, c) [(c, l)]) - --- Concatenation of regexps (EXPORTED) --- -(+>) :: Regexp s t -> Regexp s t -> Regexp s t -(+>) = (.) - --- Close a regular expression with an action that converts the lexeme into a --- token (EXPORTED) --- --- * Note: After the application of the action, the position is advanced --- according to the length of the lexeme. This implies that normal --- actions should not be used in the case where a lexeme might contain --- control characters that imply non-standard changes of the position, --- such as newlines or tabs. --- -action :: Regexp s t -> Action t -> Lexer s t -action = lexaction - -lexaction :: Regexp s t -> Action t -> Lexer s t -lexaction re a = re `lexmeta` a' - where - a' lexeme s = - case a lexeme of - Nothing -> (Nothing, s, Nothing) - Just t -> (Just (Right t), s, Nothing) - --- Variant for actions that may returns an error (EXPORTED) --- -lexactionErr :: Regexp s t -> ActionErr t -> Lexer s t -lexactionErr re a = re `lexmeta` a' - where - a' lexeme s = (Just (a lexeme), s, Nothing) - --- Close a regular expression with a meta action (EXPORTED) --- --- * Note: Meta actions have to advance the position in dependence of the --- lexeme by themselves. --- -meta :: Regexp s t -> Meta s t -> Lexer s t -meta = lexmeta - -lexmeta :: Regexp s t -> Meta s t -> Lexer s t -lexmeta re a = re (Lexer (Action a) Done) - --- useful for building meta actions -with :: b -> Maybe (Either a b) -with a = Just (Right a) - --- disjunctive combination of two regexps (EXPORTED) --- -(>|<) :: Regexp s t -> Regexp s t -> Regexp s t -re >|< re' = \l -> re l >||< re' l - --- disjunctive combination of two lexers (EXPORTED) --- -(>||<) :: Lexer s t -> Lexer s t -> Lexer s t -(Lexer a c) >||< (Lexer a' c') = Lexer (joinActions a a') (joinConts c c') - --- combine two disjunctive continuations --- -joinConts :: Cont s t -> Cont s t -> Cont s t -joinConts Done c' = c' -joinConts c Done = c -joinConts c c' = let (bn , cls ) = listify c - (bn', cls') = listify c' - in - -- note: `addsBoundsNum' can, at this point, only - -- approx. the number of *non-overlapping* cases; - -- however, the bounds are correct - -- - aggregate (addBoundsNum bn bn') (cls ++ cls') - where - listify (Dense n arr) = (n, assocs arr) - listify (Sparse n cls) = (n, cls) - listify _ = error "Lexers.listify: Impossible argument!" - --- combine two actions. Use the latter in case of overlap (!) --- -joinActions :: LexAction s t -> LexAction s t -> LexAction s t -joinActions NoAction a' = a' -joinActions a NoAction = a -joinActions _ a' = a' -- error "Lexers.>||<: Overlapping actions!" - --- Note: `n' is only an upper bound of the number of non-overlapping cases --- -aggregate :: BoundsNum -> ([(Char, Lexer s t)]) -> Cont s t -aggregate bn@(n, lc, hc) cls - | n >= denseMin = Dense bn (accumArray (>||<) noLexer (lc, hc) cls) - | otherwise = Sparse bn (accum (>||<) cls) - where - noLexer = Lexer NoAction Done - --- combine the elements in the association list that have the same key --- -accum :: Eq a => (b -> b -> b) -> [(a, b)] -> [(a, b)] -accum _ [] = [] -accum f ((c, el):ces) = - let (ce, ces') = gather c el ces - in ce : accum f ces' - where - gather k e [] = ((k, e), []) - gather k e (ke'@(k', e'):kes) | k == k' = gather k (f e e') kes - | otherwise = let - (ke'', kes') = gather k e kes - in - (ke'', ke':kes') - - --- non-basic combinators --- --------------------- - --- x `star` y corresponds to the regular expression x*y (EXPORTED) --- -star :: Regexp s t -> Regexp s t -> Regexp s t --- --- The definition used below can be obtained by equational reasoning from this --- one (which is much easier to understand): --- --- star re1 re2 = let self = (re1 +> self >|< epsilon) in self +> re2 --- --- However, in the above, `self' is of type `Regexp s t' (ie, a functional), --- whereas below it is of type `Lexer s t'. Thus, below we have a graphical --- body (finite representation of an infinite structure), which doesn't grow --- with the size of the accepted lexeme - in contrast to the definition using --- the functional recursion. --- -star re1 re2 = \l -> let self = re1 self >||< re2 l - in - self - --- x `plus` y corresponds to the regular expression x+y (EXPORTED) --- -plus :: Regexp s t -> Regexp s t -> Regexp s t -plus re1 re2 = re1 +> (re1 `star` re2) - --- x `quest` y corresponds to the regular expression x?y (EXPORTED) --- -quest :: Regexp s t -> Regexp s t -> Regexp s t -quest re1 re2 = (re1 +> re2) >|< re2 - --- accepts a non-empty set of alternative characters (EXPORTED) --- -alt :: [Char] -> Regexp s t --- --- Equiv. to `(foldr1 (>|<) . map char) cs', but much faster --- -alt [] = error "Lexers.alt: Empty character set!" -alt cs = \l -> let bnds = (length cs, minimum cs, maximum cs) - in - Lexer NoAction (aggregate bnds [(c, l) | c <- cs]) - --- accept a character sequence (EXPORTED) --- -string :: String -> Regexp s t -string [] = error "Lexers.string: Empty character set!" -string cs = (foldr1 (+>) . map char) cs - - --- execution of a lexer --- -------------------- - --- threaded top-down during lexing (current input, meta state) (EXPORTED) --- -type LexerState s = (String, s) - --- apply a lexer, yielding a token sequence and a list of errors (EXPORTED) --- --- * Currently, all errors are fatal; thus, the result is undefined in case of --- an error (this changes when error correction is added). --- --- * The final lexer state is returned. --- --- * The order of the error messages is undefined. --- -execLexer :: Lexer s t -> LexerState s -> ([t], LexerState s, [Error]) --- --- * the following is moderately tuned --- -execLexer _ st@([], _) = ([], st, []) -execLexer l st = - case lexOne l st of - (Nothing , _ , st') -> execLexer l st' - (Just res, l', st') -> let (ts, final, allErrs) = execLexer l' st' - in case res of - (Left err) -> (ts , final, err:allErrs) - (Right t ) -> (t:ts, final, allErrs) - where - -- accept a single lexeme - -- - -- lexOne :: Lexer s t -> LexerState s t - -- -> (Either Error (Maybe t), Lexer s t, LexerState s t) - lexOne l0 st' = oneLexeme l0 st' zeroDL lexErr - - where - -- the result triple of `lexOne' that signals a lexical error; - -- the result state is advanced by one character for error correction - -- - lexErr = let (cs, s) = st' - err = "Lexical error!\n" ++ - "The character " ++ show (head cs) - ++ " does not fit here; skipping it." - in - (Just (Left err), l, (tail cs, s)) - - -- - -- we take an open list of characters down, where we accumulate the - -- lexeme; this function returns maybe a token, the next lexer to use - -- (can be altered by a meta action), the new lexer state, and a list - -- of errors - -- - -- we implement the "principle of the longest match" by taking a - -- potential result quadruple down (in the last argument); the - -- potential result quadruple is updated whenever we pass by an action - -- (different from `NoAction'); initially it is an error result - -- - - -- (dons): from the paper "we have to take the last possible - -- action before the automaton gets stuck. .. when no further - -- transition is possible, we execute the last action on the - -- associated lexeme." This means that even once all possible - -- actions have been looked at, we currently then wait till the - -- _next_ char, before returning the last action we're carrying - -- around. For interactive use, we instead need to execute the - -- last action once we encounter it, not once we've gone past - -- it. Hmm... - - -- - -- oneLexeme :: Lexer s t - -- -> LexerState - -- -> DList Char - -- -> (Maybe (Either Error t), Maybe (Lexer s t), - -- LexerState s t) - -- -> (Maybe (Either Error t), Maybe (Lexer s t), - -- LexerState s t) - -- - oneLexeme (Lexer a cont) state@(cs, s) csDL last = - let last' = doaction a csDL state last - in case cs of - [] -> last' -- at end, has to be this action - (c:cs') -> oneChar cont c (cs', s) csDL last' -- keep looking - - -- - -- There are more chars. Look at the next one - -- - -- Now, if the next tbl is Done, then there is no more - -- transition, so immediately execute our action - -- - oneChar tbl c state csDL last = - case peek tbl c of - Nothing -> last - Just (Lexer a Done) -> doaction a (csDL `snocDL` c) state last - Just l' -> continue l' c state csDL last - - -- - -- Do the lookup. - -- - peek Done _ = Nothing - peek (Dense bn arr) c | c `inBounds` bn = Just $ arr ! c - peek (Sparse bn cls) c | c `inBounds` bn = lookup c cls - peek _ _ = Nothing - - -- - -- continue within the current lexeme - -- - continue l' c state csDL last = - oneLexeme l' state (csDL `snocDL` c) last - - -- - -- execute the action if present and finalise the current lexeme - -- - doaction (Action f) csDL (cs, s) _last = - case f (closeDL csDL) s of - (Nothing, s', l') - | not . null $ cs -> lexOne (fromMaybe l0 l') (cs, s') - (res, s', l') -> (res, (fromMaybe l0 l'), (cs, s')) - - doaction NoAction _csDL _state last = last -- no change - ------------------------------------------------------------------------- --- --- This module provides the functional equivalent of the difference lists --- from logic programming. They provide an O(1) append. --- - - --- | a difference list is a function that given a list returns the original --- contents of the difference list prepended at the given list (EXPORTED) -type DList a = [a] -> [a] - --- | open a list for use as a difference list (EXPORTED) -{- -openDL :: [a] -> DList a -openDL = (++) --} - --- | create a difference list containing no elements (EXPORTED) -zeroDL :: DList a -zeroDL = id - --- | create difference list with given single element (EXPORTED) -{- -unitDL :: a -> DList a -unitDL = (:) --} - --- | append a single element at a difference list (EXPORTED) -snocDL :: DList a -> a -> DList a -snocDL dl x = \l -> dl (x:l) - --- | appending difference lists (EXPORTED) -{- -joinDL :: DList a -> DList a -> DList a -joinDL = (.) --} - --- | closing a difference list into a normal list (EXPORTED) -closeDL :: DList a -> [a] -closeDL = ($ []) diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,114 +0,0 @@ --- --- Copyright (c) Don Stewart 2004-2008. --- Copyright (c) Tuomo Valkonen 2004. --- Copyright (c) 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. --- - -module Main where - -import Base - -import Core (start, shutdown) -import Config (help, versinfo) -import Tree (Tree, buildTree, isEmpty) - -import System.IO (hPrint, stderr) -import System.Posix.Signals (installHandler, sigTERM, sigPIPE, sigINT, sigHUP - ,sigALRM, sigABRT, Handler(Ignore, Default, Catch)) - --- --------------------------------------------------------------------- --- | Set up the signal handlers - --- --- Notes on setStoppedChildFlag: --- If this bit is set when installing a catching function for the SIGCHLD --- signal, the SIGCHLD signal will be generated only when a child process --- exits, not when a child process stops. --- --- setStoppedChildFlag True --- -initSignals :: IO () -initSignals = do - - -- ignore - for_ [sigPIPE, sigALRM] \sig -> - installHandler sig Ignore Nothing - - -- and exit if we get the following - for_ [sigINT, sigHUP, sigABRT, sigTERM] \sig -> - installHandler sig (Catch (do - catch (shutdown Nothing) (\ (f :: SomeException) -> hPrint stderr f) - exitWith (ExitFailure 1) )) Nothing - --- XXX this function is not used -releaseSignals :: IO () -releaseSignals = - for_ [sigINT, sigPIPE, sigHUP, sigABRT, sigTERM] - \sig -> installHandler sig Default Nothing - ------------------------------------------------------------------------- --- | Argument parsing. - --- usage string. -usage :: [String] -usage = ["Usage: hmp3 [-VhP] [FILE|DIR ...]" - ,"-V --version Show version information" - ,"-h --help Show this help" - ,"-P --paused Start in a paused state" - ] - --- | Parse the args -doArgs :: [ByteString] -> IO (Bool, Tree) -doArgs = loopArgs True where - - verLine = putStrLn $ unwords [versinfo, help] - showUsage = traverse_ putStrLn usage - - loopArgs _ [] = do - putStrLn "Specify at least one file or directory." - showUsage - exitFailure - - loopArgs _ (s:xs) - | s == "-V" || s == "--version" - = verLine *> exitSuccess - | s == "-h" || s == "--help" - = verLine *> showUsage *> exitSuccess - | s == "-P" || s == "--paused" - = loopArgs False xs - - loopArgs playNow xs = do - tree <- buildTree xs - if isEmpty tree - then putStrLn "Error: No music files found." *> exitFailure - else pure (playNow, tree) - --- --------------------------------------------------------------------- --- | Static main. This is the front end to the statically linked --- application, and the real front end, in a sense. 'dynamic_main' calls --- this after setting preferences passed from the boot loader. --- --- Initialise the ui getting an initial editor state, set signal --- handlers, then jump to ui event loop with the state. --- -main :: IO () -main = do - (playNow, files) <- doArgs . map fromString =<< getArgs - initSignals - start playNow files -- never returns - diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ replacing large sections, mainly low-level optimizations. * I added support for building with Stack. It can also be installed -from Nix. +with Nix from nixpkgs (`haskellPackages.hmp3-ng`). * There is a public GitHub issue tracker, and a GitHub action to continuously test builds. diff --git a/State.hs b/State.hs --- a/State.hs +++ b/State.hs @@ -1,22 +1,6 @@ --- -- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons --- Copyright (c) 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. --- +-- Copyright (c) 2019-2026 Galen Huntington +-- SPDX-License-Identifier: GPL-2.0-or-later -- -- | The top level application state, and operations on that value. @@ -26,25 +10,21 @@ import Base import FastIO (FiltHandle(..)) -import Syntax (Status(Stopped), Mode(..), Frame, Info,Id3) +import Syntax (Status(Stopped), Mode(..), Frame, Info, Id3, Pretty(ppr)) import Tree (FileArray, DirArray) import Style (StringA(Fast), defaultSty, UIStyle) import qualified Config (defaultStyle) import Text.Regex.PCRE.Light (Regex) import Data.Array (listArray) +import Data.ByteString (hPut) import Data.Sequence (Seq) import System.Clock (TimeSpec(..)) +import System.IO (hFlush) import System.Process (ProcessHandle) +import System.Random ------------------------------------------------------------------------- --- A state monad over IO would be another option. - --- type ST = StateT HState IO - ------------------------------------------------------------------------- - -- | The editor state type data HState = HState { music :: !FileArray @@ -54,27 +34,28 @@ ,cursor :: !Int -- mp3 under the cursor ,clock :: !(Maybe Frame) -- current clock value ,clockUpdate :: !Bool - ,mp3pid :: !(Maybe ProcessHandle) -- pid of decoder - ,writeh :: !(MVar Handle) -- handle to mp3 (should be MVars?) - ,errh :: !(MVar FiltHandle) -- error handle to mp3 - ,readf :: !(MVar FiltHandle) -- r/w pipe to mp3 + ,randomGen :: !StdGen -- random seed + ,mpgPid :: !(Maybe ProcessHandle) -- pid of decoder + ,spawns :: !Integer -- count of decoder spawns ,threads :: ![ThreadId] -- all our threads ,id3 :: !(Maybe Id3) -- maybe mp3 id3 info ,info :: !(Maybe Info) -- mp3 info ,status :: !Status ,minibuffer :: !StringA -- contents of minibuffer ,helpVisible :: !Bool -- is the help window shown? - ,histVisible :: !(Maybe [(String, (Int, String))]) -- history pop-up if shown + ,histVisible :: !(Maybe [(ByteString, (Int, ByteString))]) -- history pop-up if shown ,exitVisible :: !Bool -- confirm exit modal shown ,miniFocused :: !Bool -- is the mini buffer focused? - ,mode :: !Mode -- random mode + ,mode :: !Mode ,uptime :: !ByteString ,boottime :: !TimeSpec ,regex :: !(Maybe (Regex,Bool)) -- most recent search pattern and direction + ,searchHist :: ![String] -- history of searches ,xterm :: !Bool ,doNotResuscitate :: !Bool -- should we just let mpg123 die? - ,playHist :: Seq (TimeSpec, Int) -- limited history of songs played + ,playHist :: !(Seq (TimeSpec, Int)) -- limited history of songs played ,config :: !UIStyle -- config values + ,configPath :: !(Maybe FilePath) -- style.conf override (CLI) ,modified :: !(MVar ()) -- Set when redrawable components of -- the state are modified. The ui @@ -86,8 +67,12 @@ -- -- | The initial state -- -emptySt :: HState -emptySt = HState { +newEmptyHS :: IO HState +newEmptyHS = do + modified <- newEmptyMVar + drawLock <- newMVar () + randomGen <- newStdGen + pure HState { music = listArray (0,0) [] ,folders = listArray (0,0) [] @@ -96,16 +81,15 @@ ,cursor = 0 ,threads = [] - ,modified = unsafePerformIO newEmptyMVar - ,writeh = unsafePerformIO newEmptyMVar - ,errh = unsafePerformIO newEmptyMVar - ,readf = unsafePerformIO newEmptyMVar + ,modified - ,mp3pid = Nothing + ,mpgPid = Nothing + ,spawns = 0 ,clock = Nothing ,info = Nothing ,id3 = Nothing ,regex = Nothing + ,searchHist = [] ,clockUpdate = False ,helpVisible = False @@ -115,62 +99,68 @@ ,xterm = False ,doNotResuscitate = False -- mpg123 should be restarted + ,randomGen ,playHist = mempty ,config = Config.defaultStyle + ,configPath = Nothing ,boottime = 0 ,status = Stopped - ,mode = Once + ,mode = minBound ,minibuffer = Fast mempty defaultSty ,uptime = mempty - ,drawLock = unsafePerformIO (newMVar ()) + ,drawLock } -- --- | A global variable holding the state. Todo StateT +-- | A global variable holding the state. -- -state :: MVar HState -state = unsafePerformIO $ newMVar emptySt -{-# NOINLINE state #-} +hState :: MVar HState +hState = unsafePerformIO $ newMVar =<< newEmptyHS +{-# NOINLINE hState #-} +data Mpg = Mpg + { writeh :: !Handle + , readf :: !FiltHandle + , errh :: !FiltHandle + } + +mpg :: MVar Mpg +mpg = unsafePerformIO newEmptyMVar +{-# NOINLINE mpg #-} + +sendMpg :: Pretty a => a -> IO () +sendMpg s = withMVar mpg $ (. writeh) \h -> + hPut h (ppr s) >> hPut h "\n" >> hFlush h + ------------------------------------------------------------------------ -- state accessor functions -- | Access a component of the state with a projection function -getsST :: (HState -> a) -> IO a -getsST f = withST (pure . f) - --- | Perform a (read-only) IO action on the state -withST :: (HState -> IO a) -> IO a -withST f = readMVar state >>= f +getsHS :: (HState -> a) -> IO a +getsHS f = f <$> readMVar hState -- | Modify the state with a pure function -silentlyModifyST :: (HState -> HState) -> IO () -silentlyModifyST f = modifyMVar_ state (pure . f) - ------------------------------------------------------------------------- - -modifyST :: (HState -> HState) -> IO () -modifyST f = silentlyModifyST f <* touchST +silentlyModifyHS :: (HState -> HState) -> IO () +silentlyModifyHS f = modifyMVar_ hState (pure . f) --- | Modify the state with an IO action, triggering a refresh -modifySTM :: (HState -> IO HState) -> IO () -modifySTM f = modifyMVar_ state f <* touchST +modifyHS_ :: (HState -> HState) -> IO () +modifyHS_ f = silentlyModifyHS f <* touchHS --- | Modify the state with an IO action, returning a value -modifySTM_ :: (HState -> IO (HState,a)) -> IO a -modifySTM_ f = modifyMVar state f <* touchST +-- | Modify the state returning a value +modifyHS :: (HState -> (HState, a)) -> IO a +modifyHS f = modifyMVar hState (pure . f) <* touchHS --- | Trigger a refresh. This is the only way to update the screen -touchST :: IO () -touchST = withMVar state \st -> void $ tryPutMVar (modified st) () +-- | Trigger a refresh. This is the only way to update the screen. +touchHS :: IO () +touchHS = withMVar hState \st -> void $ tryPutMVar (modified st) () forceNextPacket :: IO () forceNextPacket = do - fh <- readMVar =<< getsST readf + fh <- readf <$> readMVar mpg writeIORef (frameCount fh) 0 withDrawLock :: IO () -> IO () withDrawLock io = do - lock <- getsST drawLock + lock <- getsHS drawLock withMVar lock $ const io diff --git a/Style.hs b/Style.hs --- a/Style.hs +++ b/Style.hs @@ -1,22 +1,6 @@ --- -- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons --- Copyright (c) 2019-2021 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. --- +-- Copyright (c) 2019-2022, 2026 Galen Huntington +-- SPDX-License-Identifier: GPL-2.0-or-later -- -- | Color manipulation @@ -47,77 +31,52 @@ ------------------------------------------------------------------------ --- | Colors -data Color - = RGB {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 - | Default - | Reverse - deriving stock (Eq,Ord) +-- | A terminal color: the terminal default, reverse-video, or one of the +-- eight ANSI hues at normal or bright intensity. (Bright is rendered with +-- the bold attribute, which is how 8-color terminals expose it.) +data Color = Default | Reverse | Color !Intensity !Hue + deriving stock (Eq, Ord, Show) +data Intensity = Normal | Bright + deriving stock (Eq, Ord, Show) + +data Hue = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White + deriving stock (Eq, Ord, Show) + -- | Foreground and background color pairs -data Style = Style !Color !Color +data Style = Style !Color !Color deriving stock (Eq,Ord) --- | Can hold an optimized ByteString or a Unicode String. -data AmbiString = B !ByteString | U !String - --- | A list of such values (the representation is optimised) -data StringA +-- | A list of styled UTF-8 ByteString segments making up one line. +-- 'Fast' is the single-segment fast path; 'FancyS' is a multi-segment line. +data StringA = Fast {-# UNPACK #-} !ByteString {-# UNPACK #-} !Style - | FancyS ![(AmbiString,Style)] -- one line made up of segments + | FancyS ![(ByteString, Style)] ------------------------------------------------------------------------ -- --- | Some simple colours (derivied from proxima\/src\/common\/CommonTypes.hs) --- --- But we don't have a light blue? --- -black, grey, darkred, red, darkgreen, green, brown, yellow :: Color -darkblue, blue, purple, magenta, darkcyan, cyan, white, brightwhite :: Color -black = RGB 0 0 0 -grey = RGB 128 128 128 -darkred = RGB 139 0 0 -red = RGB 255 0 0 -darkgreen = RGB 0 100 0 -green = RGB 0 128 0 -brown = RGB 165 42 42 -yellow = RGB 255 255 0 -darkblue = RGB 0 0 139 -blue = RGB 0 0 255 -purple = RGB 128 0 128 -magenta = RGB 255 0 255 -darkcyan = RGB 0 139 139 -cyan = RGB 0 255 255 -white = RGB 165 165 165 -brightwhite = RGB 255 255 255 - -defaultfg, defaultbg, reversefg, reversebg :: Color -defaultfg = Default -defaultbg = Default -reversefg = Reverse -reversebg = Reverse - --- --- | map strings to colors +-- | Named colors for the config file and the built-in styles. The +-- \"dark\" name of each pair is the normal-intensity hue; the plain name +-- is its bright variant (so @red@ is bright, @darkred@ is normal). -- stringToColor :: String -> Maybe Color stringToColor s = case map toLower s of - "black" -> Just black - "grey" -> Just grey - "darkred" -> Just darkred - "red" -> Just red - "darkgreen" -> Just darkgreen - "green" -> Just green - "brown" -> Just brown - "yellow" -> Just yellow - "darkblue" -> Just darkblue - "blue" -> Just blue - "purple" -> Just purple - "magenta" -> Just magenta - "darkcyan" -> Just darkcyan - "cyan" -> Just cyan - "white" -> Just white - "brightwhite" -> Just brightwhite + "black" -> Just $ Color Normal Black + "grey" -> Just $ Color Bright Black + "darkred" -> Just $ Color Normal Red + "red" -> Just $ Color Bright Red + "darkgreen" -> Just $ Color Normal Green + "green" -> Just $ Color Bright Green + "brown" -> Just $ Color Normal Yellow + "yellow" -> Just $ Color Bright Yellow + "darkblue" -> Just $ Color Normal Blue + "blue" -> Just $ Color Bright Blue + "purple" -> Just $ Color Normal Magenta + "magenta" -> Just $ Color Bright Magenta + "darkcyan" -> Just $ Color Normal Cyan + "cyan" -> Just $ Color Bright Cyan + "white" -> Just $ Color Normal White + "brightwhite" -> Just $ Color Bright White "default" -> Just Default "reverse" -> Just Reverse _ -> Nothing @@ -154,7 +113,6 @@ selected sty, titlebar sty, progress sty, blockcursor sty, cursors sty, combined sty ] (Style fg bg) = progress sty -- bonus style - pairs <- initUiColors (ls ++ [Style bg bg, Style fg fg]) writeIORef pairMap pairs -- set the background @@ -214,16 +172,6 @@ defaultColor :: Curses.Color defaultColor = fromJust $ Curses.color "default" -cblack, cred, cgreen, cyellow, cblue, cmagenta, ccyan, cwhite :: Curses.Color -cblack = fromJust $ Curses.color "black" -cred = fromJust $ Curses.color "red" -cgreen = fromJust $ Curses.color "green" -cyellow = fromJust $ Curses.color "yellow" -cblue = fromJust $ Curses.color "blue" -cmagenta = fromJust $ Curses.color "magenta" -ccyan = fromJust $ Curses.color "cyan" -cwhite = fromJust $ Curses.color "white" - -- -- Combine attribute with another attribute -- @@ -242,61 +190,38 @@ ------------------------------------------------------------------------ newtype CColor = CColor (Curses.Attr, Curses.Color) --- --- | Map Style rgb rgb colours to ncurses pairs --- TODO a generic way to turn an rgb into the nearest curses color --- + +-- | Map an abstract 'Style' to its ncurses foreground/background pair. style2curses :: Style -> (CColor, CColor) style2curses (Style fg bg) = (fgCursCol fg, bgCursCol bg) {-# INLINE style2curses #-} +-- | The ncurses color for each ANSI hue. +hueColor :: Hue -> Curses.Color +hueColor = fromJust . Curses.color . map toLower . show + +-- | Foreground: bright hues take the bold attribute. fgCursCol :: Color -> CColor -fgCursCol c = case c of - RGB 0 0 0 -> CColor (nullA, cblack) - RGB 128 128 128 -> CColor (boldA, cblack) - RGB 139 0 0 -> CColor (nullA, cred) - RGB 255 0 0 -> CColor (boldA, cred) - RGB 0 100 0 -> CColor (nullA, cgreen) - RGB 0 128 0 -> CColor (boldA, cgreen) - RGB 165 42 42 -> CColor (nullA, cyellow) - RGB 255 255 0 -> CColor (boldA, cyellow) - RGB 0 0 139 -> CColor (nullA, cblue) - RGB 0 0 255 -> CColor (boldA, cblue) - RGB 128 0 128 -> CColor (nullA, cmagenta) - RGB 255 0 255 -> CColor (boldA, cmagenta) - RGB 0 139 139 -> CColor (nullA, ccyan) - RGB 0 255 255 -> CColor (boldA, ccyan) - RGB 165 165 165 -> CColor (nullA, cwhite) - RGB 255 255 255 -> CColor (boldA, cwhite) - Default -> CColor (nullA, defaultColor) - Reverse -> CColor (reverseA, defaultColor) - _ -> CColor (nullA, cblack) -- NB +fgCursCol = \case + Default -> CColor (nullA, defaultColor) + Reverse -> CColor (reverseA, defaultColor) + Color Bright h -> CColor (boldA, hueColor h) + Color Normal h -> CColor (nullA, hueColor h) +-- | Background: a terminal can't embolden a background, so intensity is +-- dropped here. bgCursCol :: Color -> CColor -bgCursCol c = case c of - RGB 0 0 0 -> CColor (nullA, cblack) - RGB 128 128 128 -> CColor (nullA, cblack) - RGB 139 0 0 -> CColor (nullA, cred) - RGB 255 0 0 -> CColor (nullA, cred) - RGB 0 100 0 -> CColor (nullA, cgreen) - RGB 0 128 0 -> CColor (nullA, cgreen) - RGB 165 42 42 -> CColor (nullA, cyellow) - RGB 255 255 0 -> CColor (nullA, cyellow) - RGB 0 0 139 -> CColor (nullA, cblue) - RGB 0 0 255 -> CColor (nullA, cblue) - RGB 128 0 128 -> CColor (nullA, cmagenta) - RGB 255 0 255 -> CColor (nullA, cmagenta) - RGB 0 139 139 -> CColor (nullA, ccyan) - RGB 0 255 255 -> CColor (nullA, ccyan) - RGB 165 165 165 -> CColor (nullA, cwhite) - RGB 255 255 255 -> CColor (nullA, cwhite) - Default -> CColor (nullA, defaultColor) - Reverse -> CColor (reverseA, defaultColor) - _ -> CColor (nullA, cwhite) -- NB +bgCursCol = \case + Default -> CColor (nullA, defaultColor) + Reverse -> CColor (reverseA, defaultColor) + Color _ h -> CColor (nullA, hueColor h) defaultSty :: Style defaultSty = Style Default Default +style :: String -> String -> Style +style a b = let f = fromJust . stringToColor in Style (f a) (f b) + ------------------------------------------------------------------------ -- -- Support for runtime configuration @@ -338,3 +263,4 @@ where f (x,y) = Style (g x) (g y) g x = fromMaybe Default $ stringToColor x + diff --git a/Syntax.hs b/Syntax.hs --- a/Syntax.hs +++ b/Syntax.hs @@ -1,22 +1,6 @@ --- -- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons --- Copyright (c) 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. --- +-- Copyright (c) 2019-2026 Galen Huntington +-- SPDX-License-Identifier: GPL-2.0-or-later -- -- abstract syntax for mpg123/321 'remote control' commands, so we get @@ -66,17 +50,20 @@ -- mpg123 tagline. Output at startup. data Tag = Tag + deriving stock (Eq, Show) -- Track info if ID fields are in the file, otherwise file name. newtype File = File (Either ByteString Id3) + deriving stock (Eq, Show) --- ID3 info +-- ID3 info data Id3 = Id3 { id3title :: !ByteString , id3artist :: !ByteString , id3album :: !ByteString , id3str :: !ByteString } + deriving stock (Eq, Show) -- , year :: Maybe ByteString -- , genre :: Maybe ByteString } @@ -111,8 +98,9 @@ -- checksummed :: !Bool, -- emphasis :: !Int, -- bitrate :: !Int, - -- extension :: !Int + -- extension :: !Int } + deriving stock (Eq, Show) -- @F -- Frame decoding status updates (once per frame). @@ -128,6 +116,7 @@ currentTime :: !(Fixed E2), timeLeft :: !(Fixed E2) } + deriving stock (Eq, Show) -- @P {0, 1, 2} -- Stop/pause status. @@ -158,3 +147,4 @@ | I {-# UNPACK #-} !Info | R {-# UNPACK #-} !Frame | S !Status + deriving stock (Eq, Show) diff --git a/Tree.hs b/Tree.hs --- a/Tree.hs +++ b/Tree.hs @@ -1,23 +1,6 @@ -{-# OPTIONS -fno-warn-orphans #-} --- -- Copyright (c) 2005-8 Don Stewart - http://www.cse.unsw.edu.au/~dons --- Copyright (c) 2019-2020, 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. --- +-- Copyright (c) 2019-2020, 2025-2026 Galen Huntington +-- SPDX-License-Identifier: GPL-2.0-or-later -- -- functions for manipulating file trees @@ -29,6 +12,7 @@ import FastIO import qualified Data.ByteString.Char8 as P +import qualified Data.Map.Strict as M import Data.Array import System.IO (hPrint, stderr) @@ -91,15 +75,7 @@ -- | Merge entries with the same root node into a single node merge :: [(FilePathP, [FilePathP])] -> [(FilePathP, [FilePathP])] -merge [] = [] -merge xs = - let xs' = sortBy (\a b -> fst a `compare` fst b) xs - xs''= groupBy (\a b -> fst a == fst b) xs' - in mapMaybe flatten xs'' - where - flatten :: [(FilePathP,[FilePathP])] -> Maybe (FilePathP, [FilePathP]) - flatten [] = Nothing -- can't happen - flatten (x:ys) = let d = fst x in Just (d, snd x ++ concatMap snd ys) +merge = M.assocs . M.fromListWith (flip (++)) -- | fold builder, for generating Dirs and Files make :: (Int,Int,[Dir],[File]) -> (FilePathP,[FilePathP]) -> (Int,Int,[Dir],[File]) @@ -127,14 +103,9 @@ let fs = filter onlyMp3s fs' v = if null fs then Nothing else Just (f,fs) pure (v,ds) - where - notEdge p = p /= dot && p /= dotdot - validFiles p = notEdge p - onlyMp3s p = mp3 == (P.map toLower . P.drop (P.length p - 3) $ p) - - mp3 = "mp3" - dot = "." - dotdot = ".." + where + validFiles = not . P.isPrefixOf "." + onlyMp3s = P.isSuffixOf ".mp3" . P.map toLower -- -- | Given an the next index into the files array, a directory name, and diff --git a/UI.hs b/UI.hs --- a/UI.hs +++ b/UI.hs @@ -1,29 +1,11 @@ {-# LANGUAGE ForeignFunctionInterface, TupleSections, AllowAmbiguousTypes #-} --- --- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons --- Copyright (c) 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. --- --- Derived from: riot/UI.hs --- Copyright (c) Tuomo Valkonen 2004. +-- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2019-2026 Galen Huntington +-- SPDX-License-Identifier: GPL-2.0-or-later -- +-- Derived from: riot/UI.hs Copyright (c) Tuomo Valkonen 2004. -- Released under the same license. --- -- -- | This module defines a user interface implemented using ncurses. @@ -31,15 +13,12 @@ -- module UI ( - runDraw, - - -- * Construction, destruction - start, end, suspend, screenSize, refresh, refreshClock, resetui, - - -- * Input - getKey - - ) where + runDraw, + -- * Construction, destruction + start, end, suspend, screenSize, refresh, refreshClock, resetui, + -- * Input + getKey + ) where import Base @@ -49,10 +28,11 @@ import State import Syntax import Config +import Width (displayWidth, toMaxWidth, toWidth) import qualified UI.HSCurses.Curses as Curses -import {-# SOURCE #-} Keymap (extraTable, keyTable, unkey, charToKey) +import {-# SOURCE #-} Keymap (keyTable, unkey, charToKey) -import Data.Array ((!), bounds, Array, listArray) +import Data.Array ((!), bounds, Array) import Data.Array.Base (unsafeAt) import System.IO (stderr, hFlush) import System.Posix.Signals (raiseSignal, sigTSTP, installHandler, Handler(..)) @@ -62,10 +42,15 @@ import Foreign.C.Error (Errno(..), getErrno) import qualified Data.ByteString.Char8 as P -import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as P import qualified Data.ByteString.UTF8 as UTF8 +-- Write u-strings like it's Python 2. +u :: String -> ByteString +u = UTF8.fromString + + newtype Draw = Draw (IO ()) instance Semigroup Draw where Draw x <> Draw y = Draw $ x >> y instance Monoid Draw where mempty = Draw $ pure () @@ -75,9 +60,7 @@ ------------------------------------------------------------------------ --- --- | how to initialise the ui --- +-- | Initialize the UI start :: IO UIStyle start = do discardErrors do @@ -85,7 +68,7 @@ case thisterm of Just "vt220" -> setEnv "TERM" "xterm-color" Just t | "xterm" `isPrefixOf` t - -> silentlyModifyST $ \st -> st { xterm = True } + -> silentlyModifyHS $ \st -> st { xterm = True } _ -> pure () Curses.initCurses @@ -94,11 +77,7 @@ _ -> pure () -- handled elsewhere colorify <- Curses.hasColors - light <- isLightBg - - let sty | colorify && light = lightBgStyle - | colorify = defaultStyle - | otherwise = bwStyle + let sty = if colorify then defaultStyle else bwStyle initcolours sty Curses.keypad Curses.stdScr True -- grab the keyboard @@ -118,8 +97,9 @@ -- | Clean up and go home. Refresh is needed on linux. grr. -- end :: Bool -> IO () -end isXterm = do when isXterm $ setXtermTitle ["xterm"] - Curses.endWin +end isXterm = withDrawLock do + when isXterm $ setXtermTitle ["xterm"] + Curses.endWin -- -- | Suspend the program @@ -172,7 +152,7 @@ do -- not sure I need all these... Curses.nl True - Curses.leaveOk True + _ <- Curses.leaveOk True Curses.noDelay Curses.stdScr False Curses.cBreak True -- Curses.meta stdScr True -- not in module @@ -186,14 +166,6 @@ refreshClock :: IO () refreshClock = runDraw $ redrawJustClock <> Draw Curses.refresh --- --- | Some evil to work out if the background is light, or dark. Assume dark. --- -isLightBg :: IO Bool -isLightBg = handle @SomeException (\_ -> pure False) do - e <- getEnv "HMP_HAS_LIGHT_BG" - pure $ map toLower e == "true" - ------------------------------------------------------------------------ -- (prefix some with underscore to avoid unused warnings) @@ -263,7 +235,7 @@ ------------------------------------------------------------------------ -instance (Element a, Element b) => Element (a,b) where +instance (Element a, Element b) => Element (a, b) where draw dd = (draw dd, draw dd) ------------------------------------------------------------------------ @@ -271,39 +243,32 @@ -- Info about the current track instance Element PPlaying where draw dd = - PPlaying . FancyS $ map (, defaultSty) $ spc2 : line + PPlaying . FancyS $ map (, defaultSty) $ " " : line where x = sizeW $ drawSize dd PId3 a = draw dd PInfo b = draw dd - s = UTF8.toString a - line | gap >= 0 = U s : B (spaces gap) : right - | True = U (ellipsize lim s) : right + line | gap >= 0 = a : spaces gap : right + | True = toMaxWidth lim a : right where lim = x - 5 - (if showId3 then P.length b else -1) - gap = lim - displayWidth s + gap = lim - displayWidth a showId3 = x > 59 - right = if showId3 then [B " ", B b] else [] + right = if showId3 then [" ", b] else [] -- | Id3 Info instance Element PId3 where draw DD{drawState=st} = case id3 st of Just i -> PId3 $ id3str i Nothing -> PId3 $ case size st of - 0 -> emptyVal + 0 -> "(empty)" _ -> fbase $ music st ! current st -- | mp3 information instance Element PInfo where draw DD{drawState=st} = PInfo case info st of - Nothing -> emptyVal + Nothing -> "(empty)" Just i -> userinfo i -emptyVal :: ByteString -emptyVal = "(empty)" - -spc2 :: AmbiString -spc2 = B $ spaces 2 - modalWidth :: Int -> Int modalWidth w = max (min w 3) $ round $ fromIntegral w * (0.8::Float) @@ -314,43 +279,40 @@ instance ModalElement HelpModal where drawModal sty swd st = do guard $ helpVisible st - pure $ (wd,) $ - [ Fast (f cs h) sty | (h,cs,_) <- keyTable ] ++ - [ Fast (f cs h) sty | (h,cs) <- extraTable ] - where - wd = modalWidth swd - f :: [Char] -> String -> ByteString - f cs ps = UTF8.fromString $ forceWidth wd - $ forceWidth clen cmds <> ps where - clen = max 4 $ round $ fromIntegral wd * (0.2::Float) - cmds = unwords $ "" : map pprIt cs - pprIt c = case c of - '\n' -> "Enter" - '\f' -> "^L" - '\\' -> "\\" - ' ' -> "Space" - _ -> case charToKey c of - Curses.KeyUp -> "↑" - Curses.KeyDown -> "↓" - Curses.KeyPPage -> "PgUp" - Curses.KeyNPage -> "PgDn" - Curses.KeyLeft -> "←" - Curses.KeyRight -> "→" - Curses.KeyEnd -> "End" - Curses.KeyHome -> "Home" - Curses.KeyBackspace -> "Backspace" - _ -> [c] + pure (wd, [ Fast (f cs h) sty | (h, cs, _) <- keyTable ]) + where + wd = modalWidth swd + f :: [Char] -> String -> ByteString + f cs ps = toWidth wd $ toWidth clen cmds <> u ps where + clen = max 4 $ round $ fromIntegral wd * (0.2::Float) + cmds = P.unwords ("" : map pprIt cs) + pprIt c = case c of + '\n' -> "Enter" + '\f' -> "^L" + '\\' -> "\\" + ' ' -> "Space" + _ -> case charToKey c of + Curses.KeyUp -> u"↑" + Curses.KeyDown -> u"↓" + Curses.KeyPPage -> "PgUp" + Curses.KeyNPage -> "PgDn" + Curses.KeyLeft -> u"←" + Curses.KeyRight -> u"→" + Curses.KeyEnd -> "End" + Curses.KeyHome -> "Home" + Curses.KeyBackspace -> "Backspace" + _ -> u[c] ------------------------------------------------------------------------ instance ModalElement HistModal where drawModal sty swd st = flip fmap (histVisible st) \hist -> do let wd = modalWidth swd - mtlen = maximum $ map (length . fst) hist + mtlen = maximum $ map (displayWidth . fst) hist tlen = min (mtlen + 1) $ wd `div` 3 (wd,) $ flip map (zip (['0'..'9']++['a'..'z']) hist) \ (c, (time, (_, song))) -> - let tstr = ellipsize tlen $ replicate (tlen - displayWidth time) ' ' ++ time - in Fast (UTF8.fromString $ forceWidth wd $ ' ' : c : ' ' : tstr ++ ' ' : song) sty + let tstr = toMaxWidth tlen $ P.replicate (tlen - displayWidth time) ' ' <> time + in Fast (toWidth wd $ " " <> P.singleton c <> " " <> tstr <> " " <> song) sty ------------------------------------------------------------------------ @@ -358,10 +320,10 @@ drawModal sty swd st = do guard $ exitVisible st let wd = modalWidth swd `min` 19 - blank = Fast (UTF8.fromString $ forceWidth wd "") sty - padl = replicate ((wd - 9) `div` 2) ' ' - msg = forceWidth wd $ padl ++ "Exit (y)?" - pure (wd, [blank, Fast (UTF8.fromString msg) sty, blank]) + blank = Fast (toWidth wd "") sty + padl = P.replicate ((wd - 9) `div` 2) ' ' + msg = toWidth wd $ padl <> "Exit (y)?" + pure (wd, [blank, Fast msg sty, blank]) ------------------------------------------------------------------------ @@ -370,9 +332,9 @@ draw DD { drawFrame=Just Frame {..}, drawSize=Size{sizeW=x} } = PTimes $ FancyS $ map (, defaultSty) if x - 4 < P.length elapsed - then [B " "] - else [spc2, B elapsed] - ++ (guard (distance > 0) *> [B gap, B remaining]) + then [" "] + else [" ", elapsed] + ++ (guard (distance > 0) *> [gap, remaining]) where elapsed = P.pack $ printf "%d:%02d" l_m l_s remaining = P.pack $ printf "-%d:%02d" r_m r_s @@ -390,15 +352,15 @@ instance Element ProgressBar where draw dd@DD{drawSize=Size{sizeW=w}, drawState=st} = case drawFrame dd of Nothing -> ProgressBar . FancyS $ - [(spc2,defaultSty) ,(B $ spaces (w-4), bgs)] - where + [(" ", defaultSty), (spaces (w-4), bgs)] + where (Style _ bg) = progress (config st) bgs = Style bg bg Just Frame {..} -> ProgressBar . FancyS $ - [(spc2, defaultSty) - ,(B $ spaces distance, fgs) - ,(B $ spaces (width - distance), bgs)] - where + [ (" ", defaultSty) + , (spaces distance, fgs) + , (spaces (width - distance), bgs)] + where width = w - 4 total = curr + left distance = round ((curr / total) * fromIntegral width) @@ -471,17 +433,18 @@ draw dd = PlayTitle $ FancyS $ map (,hl) if gap >= 2 - then [B $ mconcat [space,inf,spaces gapl], U modes, - B $ mconcat [spaces gapr,time,space,ver,space]] + then [mconcat [" ", inf, spaces gapl], modesBS, + mconcat [spaces gapr, time, " ", ver, " "]] else let gap' = x - modlen; gapl' = gap' `div` 2 in if gap' >= 2 - then [B $ spaces gapl', U modes, B $ spaces $ gap' - gapl'] - else [B space, U $ take (x-2) modes, B space] + then [spaces gapl', modesBS, spaces $ gap' - gapl'] + else [" ", u $ take (x-2) modes, " "] where PlayInfo inf = draw dd PTime time = draw dd PlayModes modes = draw dd PVersion ver = draw dd + modesBS = u modes x = sizeW $ drawSize dd lsize = 1 + P.length inf @@ -491,7 +454,6 @@ gapl = 1 `max` ((side - lsize) `min` gap) gapr = 1 `max` (gap - gapl) modlen = 6 -- length modes - space = spaces 1 hl = titlebar . config $ drawState dd -- | Playlist @@ -512,7 +474,7 @@ -- number of screens down, and then offset buflen = height - 2 - (screens,select) = quotRem curr buflen -- keep cursor in screen + (screens, select) = quotRem curr buflen -- keep cursor in screen playing = let top = screens * buflen bot = (screens + 1) * buflen @@ -525,45 +487,44 @@ where off = screens * buflen -- TODO rewrite as fold - visible' :: [(Maybe Int, String)] + visible' :: [(Maybe Int, ByteString)] visible' = loop (-1) visible where loop _ [] = [] loop n (v:vs) = let r = if fdir v > n then Just (fdir v) else Nothing - in (r, ellipsize (x - indent - 1) $ UTF8.toString $ fbase v) + in (r, toMaxWidth (x - indent - 1) $ fbase v) : loop (fdir v) vs list = [ drawIt . color $ n | n <- zip visible' [0..] ] indent = (round $ (0.334 :: Float) * fromIntegral x) :: Int - - color :: ((Maybe Int, String), Int) - -> (Maybe Int, Style, [AmbiString]) - color ((m,s),i) + + color :: ((Maybe Int, ByteString), Int) + -> (Maybe Int, Style, [ByteString]) + color ((m,s),i) | i == select && i == playing = f sty3 | i == select = f sty2 | i == playing = f sty1 - | otherwise = (m, defaultSty, [U s]) + | otherwise = (m, defaultSty, [s]) where - f sty = (m, sty, [ - U s, - B $ spaces (x - indent - 1 - displayWidth s)]) - + f sty = (m, sty, + [s, spaces (x - indent - 1 - displayWidth s)]) + sty1 = selected . config $ st sty2 = cursors . config $ st sty3 = combined . config $ st - drawIt :: (Maybe Int, Style, [AmbiString]) -> StringA + drawIt :: (Maybe Int, Style, [ByteString]) -> StringA drawIt (Nothing, sty, v) = - FancyS $ map (, sty) $ B (spaces (1 + indent)) : v + FancyS $ map (, sty) $ spaces (1 + indent) : v drawIt (Just i, sty, v) = FancyS - $ (U d, sty') - : (B $ spaces (indent + 1 - displayWidth d), sty') + $ (d, sty') + : (spaces (indent + 1 - displayWidth d), sty') : map (, sty) v where sty' = if sty == sty2 || sty == sty3 then sty2 else sty1 - d = ellipsize (indent - 1) $ UTF8.toString $ basenameP + d = toMaxWidth (indent - 1) $ basenameP $ case size st of 0 -> "(empty)" _ -> dname $ folders st ! i @@ -577,18 +538,8 @@ ------------------------------------------------------------------------ --- | Calculate whitespaces, very common, so precompute likely values spaces :: Int -> ByteString -spaces n - | n <= 0 = "" - | n > 100 = P.replicate n ' ' -- unlikely - | otherwise = arr ! n - where - arr :: Array Int ByteString -- precompute some whitespace strs - arr = listArray (0,100) [ P.take i s100 | i <- [0..100] ] - - s100 :: ByteString - s100 = P.replicate 100 ' ' -- seems reasonable +spaces = flip P.replicate ' ' ------------------------------------------------------------------------ -- @@ -597,7 +548,7 @@ -- redrawJustClock :: Draw redrawJustClock = Draw $ discardErrors do - st <- getsST id + st <- getsHS id let fr = clock st (h, w) <- screenSize let sz = Size h w @@ -623,10 +574,9 @@ Curses.wMove Curses.stdScr voffset hoffset for_ (take mlines modal') \t -> do drawLine w t - (y',_) <- Curses.getYX Curses.stdScr + (y', _) <- Curses.getYX Curses.stdScr Curses.wMove Curses.stdScr (y'+1) hoffset --- XXX don't understand what sz is even doing renderModals :: HState -> Size -> IO () renderModals s sz = do renderModal @HelpModal s sz @@ -640,7 +590,7 @@ redraw :: Draw redraw = Draw $ discardErrors do -- linux ncurses, in particular, seems to complain a lot. this is an easy solution - s <- getsST id -- another refresh could be triggered? + s <- getsHS id -- another refresh could be triggered? let f = clock s (h, w) <- screenSize let sz = Size h w @@ -673,15 +623,14 @@ -- | Draw a coloured (or not) string to the screen -- drawLine :: Int -> StringA -> IO () -drawLine _ (Fast ps sty) = drawAmbiString (B ps) sty -drawLine _ (FancyS ls) = traverse_ (uncurry drawAmbiString) ls +drawLine _ (Fast ps sty) = drawSegment ps sty +drawLine _ (FancyS ls) = traverse_ (uncurry drawSegment) ls -drawAmbiString :: AmbiString -> Style -> IO () -drawAmbiString as sty = withStyle sty $ case as of - B ps -> void $ B.useAsCString ps \cstr -> - waddnstr Curses.stdScr cstr (fromIntegral $ P.length ps) - U s -> Curses.wAddStr Curses.stdScr s -{-# INLINE drawAmbiString #-} +-- | Write a single styled UTF-8 segment. Safe because C only reads the bytes. +drawSegment :: ByteString -> Style -> IO () +drawSegment bs sty = withStyle sty $ void $ + P.unsafeUseAsCStringLen bs \(cstr, len) -> + waddnstr Curses.stdScr cstr (fromIntegral len) ------------------------------------------------------------------------ @@ -713,7 +662,7 @@ -- | Take a slice of an array efficiently slice :: Int -> Int -> Array Int e -> [e] slice i j arr = - let (a,b) = bounds arr + let (a, b) = bounds arr in [unsafeAt arr n | n <- [max a i .. min b j] ] {-# INLINE slice #-} @@ -750,32 +699,7 @@ Paused -> ["paused"] Stopped -> ["stopped"] -displayWidth :: String -> Int -displayWidth = sum . map charWidth -sizer :: Bool -> Int -> String -> String -sizer pad w s - | dw <= w = if pad then s ++ replicate (w - dw) ' ' else s - | True = go 0 0 s where - go !i !l (c:s') = - if l' > w-1 - then take i s ++ replicate (w-l) '…' - else go (i+1) l' s' - where l' = l + charWidth c - go _ _ _ = error "Should've been in first case!" - dw = displayWidth s - -ellipsize, forceWidth :: Int -> String -> String -ellipsize = sizer False -forceWidth = sizer True - -charWidth :: Char -> Int -charWidth = fromIntegral . wcwidth . toEnum . fromEnum - -foreign import ccall safe - wcwidth :: CWchar -> CInt - --- Not exported by hscurses. foreign import ccall safe waddnstr :: Curses.Window -> CString -> CInt -> IO CInt diff --git a/Width.hs b/Width.hs new file mode 100644 --- /dev/null +++ b/Width.hs @@ -0,0 +1,45 @@ +-- Copyright (c) 2019-2026 Galen Huntington +-- SPDX-License-Identifier: GPL-2.0-or-later + +-- | Width-aware operations on UTF-8 'ByteString's, using libc 'wcwidth'. +-- A UTF-8 runtime locale is presumed; counts may differ otherwise. +module Width (displayWidth, toMaxWidth, toWidth) where + +import Base + +import qualified Data.ByteString.Char8 as P +import qualified Data.ByteString.UTF8 as UTF8 + +import Foreign.C.Types + + +-- | Sum of the column widths of every codepoint in a UTF-8 'ByteString'. +displayWidth :: ByteString -> Int +displayWidth = UTF8.foldl (\acc c -> acc + charWidth c) 0 + +-- | These functions truncate with ellipses if needed to get width ≤'w'. +-- 'toWidth' adds padding as needed so the width is exactly 'w'. +toMaxWidth, toWidth :: Int -> ByteString -> ByteString +toMaxWidth = sizer False +toWidth = sizer True + +sizer :: Bool -> Int -> ByteString -> ByteString +sizer pad w bs + | dw <= w = if pad then bs <> P.replicate (w-dw) ' ' else bs + | True = walk 0 bs + where + dw = displayWidth bs + walk !l rest + | l' >= w = P.take (P.length bs - P.length rest) bs + <> mconcat (replicate (w-l) $ UTF8.fromString "…") + | True = walk l' rest' + where + (c, rest') = fromJust $ UTF8.uncons rest -- can't be at end since dw>w + l' = l + charWidth c + +charWidth :: Char -> Int +charWidth = fromIntegral . wcwidth . toEnum . fromEnum + +foreign import ccall safe + wcwidth :: CWchar -> CInt + diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,79 @@ +-- Copyright (c) Don Stewart 2004-2008. +-- Copyright (c) Tuomo Valkonen 2004. +-- Copyright (c) 2019-2026 Galen Huntington +-- SPDX-License-Identifier: GPL-2.0-or-later + +module Main where + +import Base + +import Core (start, shutdown, Options(..)) +import qualified Config +import Tree (buildTree, isEmpty) + +import System.IO (hPrint, stderr) +import System.Posix.Signals (installHandler, sigTERM, sigPIPE, sigINT, sigHUP + ,sigALRM, sigABRT, Handler(Ignore, Default, Catch)) + +import qualified Data.ByteString.UTF8 as UTF8 + +import Options.Applicative + +-- --------------------------------------------------------------------- +-- | Set up the signal handlers + +initSignals :: IO () +initSignals = do + -- ignore + for_ [sigPIPE, sigALRM] \sig -> + installHandler sig Ignore Nothing + -- and exit if we get the following + for_ [sigINT, sigHUP, sigABRT, sigTERM] \sig -> + installHandler sig (Catch exitHandler) Nothing + +exitHandler :: IO () +exitHandler = do + releaseSignals -- in case shutdown itself gets stuck + catch @SomeException (shutdown Nothing) (hPrint stderr) + exitWith $ ExitFailure 1 + +releaseSignals :: IO () +releaseSignals = + for_ [sigINT, sigPIPE, sigHUP, sigABRT, sigTERM] \sig -> + installHandler sig Default Nothing + +------------------------------------------------------------------------ +-- | Command-line parsing. + +-- | The options together with the file/directory arguments. +invocation :: Parser (Options, [ByteString]) +invocation = (,) <$> opts <*> files + where + opts = Options + <$> switch + (long "paused" <> short 'P' <> help "Start in a paused state") + <*> optional (strOption -- temporarily internal since feature needs work + (long "config" <> short 'c' <> metavar "FILE" <> internal + <> help "Read this config file instead of the XDG default")) + files = some $ argument (UTF8.fromString <$> str) (metavar "FILE|DIR...") + +parserInfo :: ParserInfo (Options, [ByteString]) +parserInfo = info (invocation <**> versionOpt <**> helper) $ + fullDesc + <> header Config.versinfo + <> progDesc "Play mp3 files in a curses interface." + where + versionOpt = infoOption Config.versinfo + (hidden <> long "version" <> short 'V' <> help "Show version information") + +------------------------------------------------------------------------ + +main :: IO () +main = do + (opts, args) <- customExecParser (prefs showHelpOnEmpty) parserInfo + initSignals + tree <- buildTree args + if isEmpty tree + then putStrLn "Error: No music files found." *> exitFailure + else start opts tree -- never returns + diff --git a/hmp3-ng.cabal b/hmp3-ng.cabal --- a/hmp3-ng.cabal +++ b/hmp3-ng.cabal @@ -1,7 +1,7 @@ -cabal-version: 2.2 +cabal-version: 3.0 name: hmp3-ng -version: 2.17.3 +version: 2.18.0 synopsis: A 2019 fork of an ncurses mp3 player written in Haskell description: An mp3 player with a curses frontend. Playlists are populated by passing file and directory names on the command line. 'h' displays @@ -15,48 +15,52 @@ license-file: LICENSE build-type: Simple extra-source-files: - README.md Keymap.hs-boot +extra-doc-files: + README.md source-repository head type: git location: https://github.com/galenhuntington/hmp3-ng -executable hmp3 - main-is: Main.hs - other-modules: +common opts + default-language: Haskell2010 + default-extensions: + BangPatterns + BlockArguments + OverloadedStrings + ScopedTypeVariables + TypeApplications + DerivingStrategies + RecordWildCards + LambdaCase + MultiWayIf + StandaloneDeriving + NumericUnderscores + NamedFieldPuns + ghc-options: -Wall -funbox-strict-fields + +library + import: opts + hs-source-dirs: ./ + exposed-modules: Base Config Core FastIO Keymap Lexer - Lexers State Style Syntax Tree UI + Width + other-modules: Paths_hmp3_ng autogen-modules: Paths_hmp3_ng - hs-source-dirs: - ./ - default-extensions: - BangPatterns - BlockArguments - NondecreasingIndentation - OverloadedStrings - ScopedTypeVariables - TypeApplications - DerivingStrategies - RecordWildCards - LambdaCase - MultiWayIf - StandaloneDeriving - NumericUnderscores - ghc-options: -Wall -funbox-strict-fields -threaded -Wno-unused-do-bind - extra-libraries: + pkgconfig-depends: ncursesw build-depends: , array @@ -73,5 +77,39 @@ , random , unix >=2.7 , utf8-string - default-language: Haskell2010 + +executable hmp3 + import: opts + main-is: Main.hs + hs-source-dirs: app + ghc-options: -threaded + build-depends: + , base + , bytestring + , hmp3-ng + , optparse-applicative + , unix + , utf8-string + +test-suite test + import: opts + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: + ConfigSpec + CoreSpec + FastIOSpec + LexerSpec + StyleSpec + TreeSpec + WidthSpec + build-depends: + , base + , bytestring + , clock + , hmp3-ng + , tasty >=1.4 + , tasty-hunit >=0.10 + , utf8-string diff --git a/test/ConfigSpec.hs b/test/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/ConfigSpec.hs @@ -0,0 +1,35 @@ +module ConfigSpec (tests) where + +import Control.Exception +import Data.Either (isRight) + +import Test.Tasty +import Test.Tasty.HUnit + +import Config (fixedStyles, defaultStyle) +import Style (UIStyle(..), style) + +tests :: TestTree +tests = testGroup "Config" + [ testGroup "styles" + [ testStyles "built-in styles valid" fixedStyles True + , testStyles "wrong style invalid" badStyles False + ] + ] + +-- Check WHNF evaluation doesn't throw. +-- Suffices because UIStyle is recursively strict. +evalOk :: a -> IO Bool +evalOk = fmap isRight . try @SomeException . evaluate + +testStyles :: Traversable t => String -> t UIStyle -> Bool -> TestTree +testStyles s m b = testCase s $ (@?= b) . and =<< traverse evalOk m + +-- Test that test actually tests. +badStyles :: [UIStyle] +badStyles = + [ defaultStyle + , defaultStyle { window = style "badcolor" "default" } + , defaultStyle + ] + diff --git a/test/CoreSpec.hs b/test/CoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/CoreSpec.hs @@ -0,0 +1,44 @@ +module CoreSpec (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import System.Clock (TimeSpec(..)) + +import Core (showTimeDiff_) + +tests :: TestTree +tests = testGroup "Core" + [ testGroup "showTimeDiff_ (secs=False)" + [ testCase "under a minute is 0m" + $ showTimeDiff_ False (t 0) (t 30) @?= "0m" + , testCase "exactly one minute" + $ showTimeDiff_ False (t 0) (t 60) @?= "1m" + , testCase "under an hour" + $ showTimeDiff_ False (t 0) (t 599) @?= "9m" + , testCase "exactly one hour" + $ showTimeDiff_ False (t 0) (t 3600) @?= "1h00m" + , testCase "one hour, one minute, one second drops seconds" + $ showTimeDiff_ False (t 0) (t 3661) @?= "1h01m" + , testCase "exactly one day" + $ showTimeDiff_ False (t 0) (t 86400) @?= "1d00h00m" + , testCase "day, hour, minute" + $ showTimeDiff_ False (t 0) (t 90060) @?= "1d01h01m" + ] + , testGroup "showTimeDiff_ (secs=True)" + [ testCase "thirty seconds" + $ showTimeDiff_ True (t 0) (t 30) @?= "30s" + , testCase "one minute exactly appends 00s" + $ showTimeDiff_ True (t 0) (t 60) @?= "1m00s" + , testCase "one minute thirty seconds" + $ showTimeDiff_ True (t 0) (t 90) @?= "1m30s" + , testCase "one hour one minute one second" + $ showTimeDiff_ True (t 0) (t 3661) @?= "1h01m01s" + , testCase "diff is taken from monotonic delta, not absolute values" + $ showTimeDiff_ True (t 1000) (t 1090) @?= "1m30s" + ] + ] + +-- Build a TimeSpec from a whole number of seconds. +t :: Integer -> TimeSpec +t s = TimeSpec (fromInteger s) 0 diff --git a/test/FastIOSpec.hs b/test/FastIOSpec.hs new file mode 100644 --- /dev/null +++ b/test/FastIOSpec.hs @@ -0,0 +1,42 @@ +module FastIOSpec (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import FastIO (basenameP, dirnameP, packedFileNameEndClean, trim) + +tests :: TestTree +tests = testGroup "FastIO" + [ testGroup "basenameP" + [ testCase "no slash" $ basenameP "foo" @?= "foo" + , testCase "single dir" $ basenameP "foo/bar" @?= "bar" + , testCase "leading slash" $ basenameP "/foo" @?= "foo" + , testCase "nested" $ basenameP "a/b/c/d.mp3" @?= "d.mp3" + , testCase "trailing slash" $ basenameP "foo/" @?= "" + , testCase "empty" $ basenameP "" @?= "" + ] + , testGroup "dirnameP" + [ testCase "no slash" $ dirnameP "foo" @?= "." + , testCase "single dir" $ dirnameP "foo/bar" @?= "foo" + , testCase "leading slash" $ dirnameP "/foo" @?= "" + , testCase "nested" $ dirnameP "a/b/c/d.mp3" @?= "a/b/c" + ] + , testGroup "trim" + [ testCase "no whitespace" $ trim "foo" @?= "foo" + , testCase "leading spaces" $ trim " foo" @?= "foo" + , testCase "trailing spaces" $ trim "foo " @?= "foo" + , testCase "both" $ trim " foo " @?= "foo" + , testCase "internal preserved" $ trim " foo bar " @?= "foo bar" + , testCase "tabs and newlines" $ trim "\t foo \n" @?= "foo" + , testCase "whitespace only" $ trim " " @?= "" + , testCase "empty" $ trim "" @?= "" + ] + , testGroup "packedFileNameEndClean" + [ testCase "no trailing" $ packedFileNameEndClean "foo" @?= "foo" + , testCase "trailing slash" $ packedFileNameEndClean "foo/" @?= "foo" + , testCase "trailing backslash" $ packedFileNameEndClean "foo\\" @?= "foo" + , testCase "multiple trailing" $ packedFileNameEndClean "foo/\\/" @?= "foo" + , testCase "internal preserved" $ packedFileNameEndClean "a/b/c/" @?= "a/b/c" + , testCase "empty" $ packedFileNameEndClean "" @?= "" + ] + ] diff --git a/test/LexerSpec.hs b/test/LexerSpec.hs new file mode 100644 --- /dev/null +++ b/test/LexerSpec.hs @@ -0,0 +1,59 @@ +module LexerSpec (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Data.ByteString.Char8 as P + +import Lexer (doP, doF, doS, doI) +import Syntax + +tests :: TestTree +tests = testGroup "Lexer" + [ testGroup "doP (status messages)" + [ testCase "0 is Stopped" $ doP "0" @?= S Stopped + , testCase "1 is Paused" $ doP "1" @?= S Paused + , testCase "2 is Playing" $ doP "2" @?= S Playing + , testCase "3 is Playing" $ doP "3" @?= S Playing + , testCase "empty is Playing" $ doP "" @?= S Playing + , testCase "garbage is Playing" $ doP "xyz" @?= S Playing + ] + , testGroup "doF (frame messages)" + [ testCase "all four fields parse" $ + doF "123 456 12.34 56.78" @?= R (Frame 123 456 12.34 56.78) + , testCase "negative timeLeft is clamped to zero" $ + doF "0 0 0.00 -1.00" @?= R (Frame 0 0 0.00 0) + ] + , testGroup "doS (info messages)" + [ testCase "userinfo combines version, bitrate, kHz" $ + doS "1.0 1 44100 stereo 0 0 2 0 0 0 128 0" + @?= I (Info "mpeg 1.0 128kbit/s 44kHz") + ] + , testGroup "doI (track info / id3)" + [ testCase "non-id3 input becomes Left filename" $ + doI "song.mp3" + @?= F (File (Left "song.mp3")) + , testCase "non-id3 input is trimmed" $ + doI " song.mp3 " + @?= F (File (Left "song.mp3")) + , testCase "id3 with title only" $ + doI ("ID3:" <> field30 "Title") + @?= F (File (Right (Id3 "Title" "" "" "Title"))) + , testCase "id3 with title and artist" $ + doI ("ID3:" <> field30 "Title" <> field30 "Artist") + @?= F (File (Right (Id3 "Title" "Artist" "" "Artist : Title"))) + , testCase "id3 with title, artist, and album" $ + doI ("ID3:" <> field30 "Title" <> field30 "Artist" <> field30 "Album") + @?= F (File (Right (Id3 "Title" "Artist" "Album" "Artist : Album : Title"))) + , testCase "id3 with empty title falls back to Left of trimmed input" $ + -- mpg123 sometimes returns ID3 records with a blank title; rather than + -- present an empty track name, the parser exposes the raw line. + doI ("ID3:" <> field30 "" <> field30 "Artist") + @?= F (File (Left ("ID3:" <> P.replicate 30 ' ' <> "Artist"))) + ] + ] + +-- Pad/truncate a ByteString to exactly 30 characters with trailing spaces, +-- matching the fixed-width field convention used by mpg123 ID3 output. +field30 :: P.ByteString -> P.ByteString +field30 b = P.take 30 (b <> P.replicate 30 ' ') diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,23 @@ +module Main (main) where + +import Test.Tasty + +import qualified ConfigSpec +import qualified CoreSpec +import qualified FastIOSpec +import qualified LexerSpec +import qualified StyleSpec +import qualified TreeSpec +import qualified WidthSpec + +main :: IO () +main = defaultMain $ testGroup "hmp3-ng" + [ ConfigSpec.tests + , CoreSpec.tests + , FastIOSpec.tests + , LexerSpec.tests + , StyleSpec.tests + , TreeSpec.tests + , WidthSpec.tests + ] + diff --git a/test/StyleSpec.hs b/test/StyleSpec.hs new file mode 100644 --- /dev/null +++ b/test/StyleSpec.hs @@ -0,0 +1,36 @@ +module StyleSpec (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Style + +-- Lock in the config-string -> Color mapping and, with it, the intensity +-- assignment of each named color (the "dark" name is normal intensity, the +-- plain name is bright). This guards the 8-color table against accidental +-- transcription errors. + +tests :: TestTree +tests = testGroup "Style" + [ testGroup "stringToColor" + [ testCase "plain name is the bright hue" + $ stringToColor "red" @?= Just (Color Bright Red) + , testCase "dark name is the normal hue" + $ stringToColor "darkred" @?= Just (Color Normal Red) + , testCase "grey is bright black" + $ stringToColor "grey" @?= Just (Color Bright Black) + , testCase "brightwhite is bright white" + $ stringToColor "brightwhite" @?= Just (Color Bright White) + , testCase "brown is normal yellow" + $ stringToColor "brown" @?= Just (Color Normal Yellow) + , testCase "case-insensitive" + $ stringToColor "ReD" @?= Just (Color Bright Red) + , testCase "default" + $ stringToColor "default" @?= Just Default + , testCase "reverse" + $ stringToColor "reverse" @?= Just Reverse + , testCase "unknown name" + $ stringToColor "chartreuse" @?= Nothing + ] + ] + diff --git a/test/TreeSpec.hs b/test/TreeSpec.hs new file mode 100644 --- /dev/null +++ b/test/TreeSpec.hs @@ -0,0 +1,38 @@ +module TreeSpec (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Tree (doOrphans, merge) + +tests :: TestTree +tests = testGroup "Tree" + [ testGroup "doOrphans" + [ testCase "empty" + $ doOrphans [] @?= [] + , testCase "bare filename" + $ doOrphans ["song.mp3"] @?= [(".", ["song.mp3"])] + , testCase "single directory" + $ doOrphans ["a/song.mp3"] @?= [("a", ["song.mp3"])] + , testCase "nested directory" + $ doOrphans ["a/b/song.mp3"] @?= [("a/b", ["song.mp3"])] + , testCase "multiple, no merging here" + $ doOrphans ["a/x.mp3", "a/y.mp3"] @?= [("a", ["x.mp3"]), ("a", ["y.mp3"])] + ] + , testGroup "merge" + [ testCase "empty" + $ merge [] @?= [] + , testCase "singleton passes through" + $ merge [("a", ["x"])] @?= [("a", ["x"])] + , testCase "different keys are sorted" + $ merge [("b", ["1"]), ("a", ["2"])] @?= [("a", ["2"]), ("b", ["1"])] + , testCase "same key combines values" + $ merge [("a", ["x"]), ("a", ["y"])] @?= [("a", ["x", "y"])] + , testCase "preserves value order within a key" + $ merge [("a", ["1"]), ("a", ["2"]), ("a", ["3"])] @?= [("a", ["1", "2", "3"])] + , testCase "value lists with multiple elements" + $ merge [("a", ["x", "y"]), ("a", ["z"])] @?= [("a", ["x", "y", "z"])] + , testCase "interleaved keys" + $ merge [("a", ["1"]), ("b", ["2"]), ("a", ["3"])] @?= [("a", ["1", "3"]), ("b", ["2"])] + ] + ] diff --git a/test/WidthSpec.hs b/test/WidthSpec.hs new file mode 100644 --- /dev/null +++ b/test/WidthSpec.hs @@ -0,0 +1,65 @@ +module WidthSpec (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.ByteString (ByteString) +import qualified Data.ByteString.UTF8 as UTF8 + +import Width (displayWidth, toMaxWidth, toWidth) + +-- These tests depend on wcwidth's behaviour under a UTF-8 locale and on a +-- handful of codepoints whose canonical widths are well-known: +-- * ASCII chars are 1 column. +-- * Latin-Extended chars (é, ñ) are 1 column. +-- * Common CJK chars (中) are 2 columns. +-- * The horizontal ellipsis (…) is 1 column. +-- They are not deterministic under the C locale. + +tests :: TestTree +tests = testGroup "Width" + [ testGroup "displayWidth" + [ testCase "empty" $ displayWidth "" @?= 0 + , testCase "ascii" $ displayWidth "hello" @?= 5 + , testCase "latin-extended" $ displayWidth (u"café") @?= 4 + , testCase "cjk doubles each" $ displayWidth (u"中文") @?= 4 + , testCase "mixed" $ displayWidth (u"中a文b") @?= 6 + ] + , testGroup "toMaxWidth" + [ testCase "wider than input passes through" + $ toMaxWidth 10 "hello" @?= "hello" + , testCase "exactly the width passes through" + $ toMaxWidth 5 "hello" @?= "hello" + , testCase "truncate ascii with ellipsis" + $ toMaxWidth 4 "hello" @?= "hel" <> u"…" + , testCase "narrower truncate" + $ toMaxWidth 2 "hello" @?= "h" <> u"…" + , testCase "width one becomes a lone ellipsis" + $ toMaxWidth 1 "hello" @?= u"…" + , testCase "width zero becomes empty" + $ toMaxWidth 0 "hello" @?= "" + , testCase "wide char truncation respects boundaries" + -- "中文hi" is 6 columns (2+2+1+1); toMaxWidth 4 keeps the first + -- wide char plus two ellipses to fill the remaining columns. + $ toMaxWidth 4 (u"中文hi") @?= u"中……" + , testCase "wide char gives way to single ellipsis at the boundary" + -- "中文" is 4 columns; toMaxWidth 3 keeps the first wide char + -- (2 columns) plus one ellipsis (1 column). + $ toMaxWidth 3 (u"中文") @?= u"中…" + ] + , testGroup "toWidth" + [ testCase "pads short ascii" + $ toWidth 10 "hello" @?= "hello " + , testCase "pad with empty input" + $ toWidth 4 "" @?= " " + , testCase "exact width unchanged" + $ toWidth 5 "hello" @?= "hello" + , testCase "truncate matches toMaxWidth when over-width" + $ toWidth 4 "hello" @?= "hel" <> u"…" + , testCase "pads after a wide-char content too" + $ toWidth 5 (u "中a") @?= u"中a" <> " " + ] + ] + +u :: String -> ByteString +u = UTF8.fromString