hmp3-ng 2.17.3 → 2.18.0
raw patch · 26 files changed
+1215/−1779 lines, 26 filesdep +hmp3-ngdep +optparse-applicativedep +tastydep ~basedep ~bytestringdep ~unix
Dependencies added: hmp3-ng, optparse-applicative, tasty, tasty-hunit
Dependency ranges changed: base, bytestring, unix
Files
- Base.hs +2/−18
- Config.hs +45/−49
- Core.hs +228/−282
- FastIO.hs +2/−27
- Keymap.hs +152/−237
- Keymap.hs-boot +2/−2
- Lexer.hs +12/−31
- Lexers.hs +0/−552
- Main.hs +0/−114
- README.md +1/−1
- State.hs +60/−70
- Style.hs +59/−133
- Syntax.hs +10/−20
- Tree.hs +7/−36
- UI.hs +106/−182
- Width.hs +45/−0
- app/Main.hs +79/−0
- hmp3-ng.cabal +63/−25
- test/ConfigSpec.hs +35/−0
- test/CoreSpec.hs +44/−0
- test/FastIOSpec.hs +42/−0
- test/LexerSpec.hs +59/−0
- test/Main.hs +23/−0
- test/StyleSpec.hs +36/−0
- test/TreeSpec.hs +38/−0
- test/WidthSpec.hs +65/−0
Base.hs view
@@ -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
Config.hs view
@@ -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"
Core.hs view
@@ -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
FastIO.hs view
@@ -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 ------------------------------------------------------------------------
Keymap.hs view
@@ -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
Keymap.hs-boot view
@@ -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+
Lexer.hs view
@@ -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
− Lexers.hs
@@ -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 <simonpj@microsoft.com> and Roman--- Lechtchinsky <wolfro@cs.tu-berlin.de> 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--- <d95mback@dtek.chalmers.se>.------- 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 <Tom.Pledger@peace.com> (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 = ($ [])
− Main.hs
@@ -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-
README.md view
@@ -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.
State.hs view
@@ -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
Style.hs view
@@ -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+
Syntax.hs view
@@ -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 <current-frame> <frames-remaining> <current-time> <time-remaining> -- 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)
Tree.hs view
@@ -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
UI.hs view
@@ -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
+ Width.hs view
@@ -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+
+ app/Main.hs view
@@ -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+
hmp3-ng.cabal view
@@ -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
+ test/ConfigSpec.hs view
@@ -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+ ]+
+ test/CoreSpec.hs view
@@ -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
+ test/FastIOSpec.hs view
@@ -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 "" @?= ""+ ]+ ]
+ test/LexerSpec.hs view
@@ -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 ' ')
+ test/Main.hs view
@@ -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+ ]+
+ test/StyleSpec.hs view
@@ -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+ ]+ ]+
+ test/TreeSpec.hs view
@@ -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"])]+ ]+ ]
+ test/WidthSpec.hs view
@@ -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