hmp3-ng 2.18.1 → 2.19.0
raw patch · 24 files changed
+664/−736 lines, 24 filesdep +regex-posixdep −pcre-lightdep ~basedep ~bytestringdep ~unix
Dependencies added: regex-posix
Dependencies removed: pcre-light
Dependency ranges changed: base, bytestring, unix
Files
- Base.hs +42/−8
- Config.hs +2/−2
- Core.hs +49/−90
- Decoder.hs +152/−0
- Keyboard.hs +6/−2
- Keymap.hs +15/−13
- Lexer.hs +0/−114
- Playlist.hs +131/−0
- README.md +2/−5
- State.hs +12/−15
- Style.hs +2/−2
- Syntax.hs +0/−107
- Tree.hs +0/−135
- UI.hs +71/−97
- Width.hs +2/−2
- app/Main.hs +23/−11
- hmp3-ng.cabal +11/−20
- test/BaseSpec.hs +30/−0
- test/DecoderSpec.hs +63/−0
- test/LexerSpec.hs +0/−65
- test/Main.hs +11/−9
- test/PlaylistSpec.hs +39/−0
- test/TreeSpec.hs +0/−38
- test/WidthSpec.hs +1/−1
Base.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- -- Copyright (c) 2020-2026 Galen Huntington -- SPDX-License-Identifier: GPL-2.0-or-later @@ -21,6 +19,7 @@ import Data.IORef as X import Data.List as X hiding ((!?)) import Data.Maybe as X+import Data.Sequence as X (Seq, (<|), (|>)) import Data.String as X import Data.Traversable as X import Data.Version as X@@ -31,6 +30,8 @@ import System.IO.Unsafe as X import Text.Printf as X import Text.Read as X (readMaybe)+import Text.Regex.Posix (match, makeRegexOptsM, compIgnoreCase, compExtended)+ import System.Clock @@ -40,12 +41,7 @@ discardErrors = X.handle @SomeException (\_ -> pure ()) getMonoTime :: IO TimeSpec-getMonoTime = getTime-#if linux_HOST_OS- Boottime-#else- Monotonic-#endif+getMonoTime = getTime Monotonic whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe $ pure ()@@ -53,4 +49,42 @@ -- Compatibility: List.!? only added in GHC 9.8 (!?) :: [a] -> Int -> Maybe a xs !? n = listToMaybe $ drop n xs+++-- API for searching+matches :: ByteString -> ByteString -> Bool++-- Layer allowing switching back end++{-+-- pcre-light version (can't use currently due to pcre3 dep)+matches s = case compileM s [caseless, utf8] of+ Right p -> \t -> isJust $ match p t []+ _ -> const False+-}++{-+-- regex-pcre2 version (fails to build in CI, not in Stackage)+matches s = case makeRegexOptsM compCaseless 0 s of+ Just p -> match p+ _ -> const False+-}++{-+-- pcre2 version (inefficient, mass Text conversion, ugly)+-- needs text dep/import+matches s =+ let p = decodeUtf8Lenient s+ in \t -> unsafePerformIO+ $ handle @SomeException (const $ pure False) $ evaluate+ $ matchesOpt Caseless p (decodeUtf8Lenient t)+-}++-- regex-posix version (reputed to be slow and buggy)+matches s = maybe (const False) match $+ makeRegexOptsM (compIgnoreCase + compExtended) 0 s++-- not yet tried:+-- regex-tdfa (mass Text conversion, parsec dep) text import+-- regex-dfa (not in Stackage, unknown engine)
Config.hs view
@@ -1,10 +1,10 @@ -- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019-2021 Galen Huntington+-- Copyright (c) 2019-2021, 2026 Galen Huntington -- SPDX-License-Identifier: GPL-2.0-or-later module Config where -import qualified Data.Map as M+import Data.Map qualified as M import Base import Style
Core.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- -- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- Copyright (c) 2008, 2019-2026 Galen Huntington -- SPDX-License-Identifier: GPL-2.0-or-later@@ -26,24 +24,22 @@ import Base -import Syntax-import Lexer (mpgParser)+import Decoder import State import Style-import Tree hiding (File, Dir)-import qualified Tree (File,Dir)-import qualified UI+import Playlist+import UI qualified -import qualified Data.ByteString.Char8 as P-import qualified Data.Sequence as Seq+import Data.ByteString.Char8 qualified as P+import Data.Sequence qualified as Seq -import Data.Array ((!), bounds, Array)+import Data.Array ((!), Array) import Data.Proxy import Data.Tuple (swap) import Control.Monad.State.Strict import System.Directory (doesFileExist, findExecutable, createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))-import System.IO (hPutStrLn, hGetLine, stderr)+import System.IO (hPutStrLn, stderr) import System.Process (runInteractiveProcess, waitForProcess) import System.Clock (TimeSpec(..), diffTimeSpec) import System.Random (randomR, newStdGen)@@ -52,16 +48,9 @@ import System.Posix.Process (exitImmediately) -import Text.Regex.PCRE.Light - mp3Tool :: String-mp3Tool =-#ifdef MPG321- "mpg321"-#else- "mpg123"-#endif+mp3Tool = "mpg123" ------------------------------------------------------------------------ @@ -69,32 +58,31 @@ data Options = Options { optPaused :: !Bool -- ^ start in a paused state , optConfigPath :: !(Maybe FilePath) -- ^ override the style.conf location+ , optPlayMode :: Maybe Mode -- ^ play mode+ , optHistSize :: Int -- ^ history size } -- | Sets up state, spawns sub-threads, and starts player.-start :: Options -> Tree -> IO ()-start opts (Tree folders music) = do+start :: Options -> Playlist -> IO ()+start opts (Playlist folders music) = do config <- catch @SomeException UI.start \err -> do -- An uncaught exception here would deadlock. -- XXX more state model revisions should obviate need hPutStrLn stderr $ "Curses failed to start: " ++ show err- exitImmediately (ExitFailure 1) *> error "Unix <2.8"+ exitImmediately $ ExitFailure 1 bootTime <- getMonoTime let size = length music- mode <- readState+ mode <- maybe readState pure (optPlayMode opts) gen <- newStdGen let (current, randomGen) = if mode == Random then randomR (0, size-1) gen else (0, gen) threads <- traverse forkIO [ mpgLoop- , mpgInput readh+ , mpgInput , refreshLoop- , clockLoop , uptimeLoop- -- mpg321 uses stderr for @F messages- , if mp3Tool == "mpg321" then mpgInput errh else errorLoop ] putMVar hState HState@@ -114,11 +102,11 @@ , clock = Nothing , info = Nothing , id3 = Nothing- , regex = Nothing , modal = Nothing , playHist = mempty , searchHist = []- , clockUpdate = False+ , searchFw = True+ , histSize = optHistSize opts , miniFocused = False , exiting = False , status = Stopped@@ -167,12 +155,12 @@ case mmpg of Nothing -> shutdown $ Just $ "Cannot find " ++ mp3Tool ++ " in path" Just mppath -> do- mv <- try $ runInteractiveProcess mppath ["-R", "-"] Nothing Nothing+ mv <- try $ runInteractiveProcess mppath ["-R", "--remote-err"] Nothing Nothing case mv of Left (ex :: SomeException) -> warnA $ mppath ++ " failed to start; retrying: " ++ show ex - Right (writeh, readh, errh, pid) -> do+ Right (writeh, _, errh, pid) -> do ct <- modifyHS $ \st -> let sp = spawns st + 1 in (st { mpgPid = Just pid , status = Stopped@@ -181,7 +169,7 @@ , spawns = sp }, sp) - putMVar mpg Mpg { readh, errh, writeh }+ putMVar mpg Mpg { errh, writeh } when (ct > 1) $ warnA $ mp3Tool ++ " #" ++ show ct ++ ": Ready" catch @SomeException (void $ waitForProcess pid) (const $ pure ())@@ -238,26 +226,13 @@ ------------------------------------------------------------------------ --- | Periodically wake up and redraw the clock-clockLoop :: IO ()-clockLoop = runForever $ threadDelay 125_000 *> UI.refreshClock------------------------------------------------------------------------------ | Handle, and display errors produced by mpg123-errorLoop :: IO ()-errorLoop = runForever $- readMVar mpg <&> errh >>= hGetLine >>= (warnA . ("mpg123 err: " ++))--------------------------------------------------------------------------- -- | Handle messages arriving over a pipe from the decoder process. When -- shutdown kills the other end of the pipe, hGetLine will fail, so we -- take that chance to exit. ---mpgInput :: (Mpg -> Handle) -> IO ()-mpgInput field = runForever $ do- line <- P.hGetLine =<< field <$> readMVar mpg+mpgInput :: IO ()+mpgInput = runForever $ do+ line <- P.hGetLine =<< errh <$> readMVar mpg case mpgParser line of Right m -> handleMsg m Left (Just e) -> warnA ("mpg123: " ++ e)@@ -266,17 +241,16 @@ ------------------------------------------------------------------------ -- | Close most things. Important to do all the jobs:--- TODO maybe releaseSignals here in case mpg is frozen?--- and/or move UI.end up?+-- TODO maybe releaseSignals here? shutdown :: Maybe String -> IO () shutdown ms = do+ UI.end silentlyModifyHS $ \st -> st { exiting = True } discardErrors writeState mpid <- getsHS mpgPid whenJust mpid \pid -> do discardErrors $ sendMpg Quit void $ waitForProcess pid- UI.end exitImmediately =<< case ms of Just s -> hPutStrLn stderr s *> pure (ExitFailure 1) _ -> pure ExitSuccess@@ -288,17 +262,17 @@ -- handleMsg :: Msg -> IO () -handleMsg (T _) = pure ()-handleMsg (I i) = modifyHS_ $ \s -> s { info = Just i }-handleMsg (F id3) = modifyHS_ $ \s -> s { id3 = Just id3 }+handleMsg (S i) = modifyHS_ $ \s -> s { info = Just i } -handleMsg (S t) = do+handleMsg (I id3) = modifyHS_ $ \s -> s { id3 = Just id3 }++handleMsg (P t) = do modifyHS_ $ \s -> s { status = t } when (t == Stopped) playNext -- transition to next song -handleMsg (R f) = do+handleMsg (F f) = do silentlyModifyHS \st -> st { clock = Just f }- getsHS clockUpdate >>= flip when UI.refreshClock+ UI.refreshClock ------------------------------------------------------------------------ --@@ -316,15 +290,11 @@ seekStart :: IO () seekStart = seek $ const 0 - -- | Generic seek seek :: (Frame -> Int) -> IO () seek fn = do mfr <- getsHS clock- whenJust mfr \fr -> do- sendMpg $ Jump (fn fr)- silentlyModifyHS $ \st -> st { clockUpdate = True }-+ whenJust mfr \fr -> sendMpg $ Jump $ fn fr ------------------------------------------------------------------------ @@ -352,7 +322,7 @@ jump = jumpFn . const -- | Jump to relative place, 0 to 1.-jumpRel :: Float -> IO ()+jumpRel :: Rational -> IO () jumpRel r | r < 0 || r >= 1 = pure () | True = modifyHS_ $ \st -> st { cursor = floor $ fromIntegral (size st) * r }@@ -436,7 +406,7 @@ { current = new , status = Playing , cursor = if current == cursor then new else cursor- , playHist = Seq.take 36 $ (now, new) Seq.<| playHist+ , playHist = Seq.take histSize $ (now, new) <| playHist , id3 = Nothing } pure f@@ -467,32 +437,27 @@ -- | Generic jump to dir jumpToDir :: (Int -> Int -> Int) -> IO ()-jumpToDir fn = modifyHS_ $ \st -> if size st == 0 then st else+jumpToDir fn = modifyHS_ \st -> let i = fdir (music st ! cursor st)- len = 1 + (snd . bounds $ folders st)- d = fn i len+ d = fn i (length $ folders st) in st { cursor = dlo (folders st ! d) } ------------------------------------------------------------------------ --- -- a bit of bounded parametric polymorphism so we can abstract over record selectors -- in the regex search stuff below--- class Lookup a where extract :: a -> RawFilePath-instance Lookup Tree.Dir where extract = takeFileName . dname-instance Lookup Tree.File where extract = fbase+instance Lookup Dir where extract = takeFileName . dname+instance Lookup File where extract = fbase jumpToMatchFile :: Maybe String -> Bool -> IO () jumpToMatchFile re sw = genericJumpToMatch re sw k sel- where k st = (music st, if size st == 0 then -1 else cursor st, size st)+ where k st = (music st, cursor st, size st) sel i _ = i 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))+ where k st = (folders st, fdir (music st ! cursor st), length $ folders st) sel i st = dlo (folders st ! i) genericJumpToMatch :: Lookup a@@ -501,25 +466,19 @@ -> (HState -> (Array Int a, Int, Int)) -> (Int -> HState -> Int) -> IO ()- genericJumpToMatch re sw k sel = do- found <- modifyHS $ \st -> do- let mre = case re of- 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+ found <- modifyHS \st -> let+ info = case re of+ Just s -> Just (st { searchFw = sw }, s, sw)+ _ -> listToMaybe [ (st, s, searchFw st == sw) | s <- searchHist st ]+ in flip (maybe (st, False)) info \(st', 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+ l = if forwards then [cur+1 .. m-1] ++ [0 .. cur]+ else [cur-1, cur-2 .. 0] ++ [m-1, m-2 .. cur]+ match = matches (P.pack p)+ case [ i | i <- l, match $ extract (fs ! i) ] of i:_ -> (st' { cursor = sel i st }, True) _ -> (st', False)- unless found $ putMessage $ Fast "No match found." defaultSty ------------------------------------------------------------------------
+ Decoder.hs view
@@ -0,0 +1,152 @@+-- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- Copyright (c) 2008, 2019-2026 Galen Huntington+-- SPDX-License-Identifier: GPL-2.0-or-later++-- Wire protocol for mpg123++module Decoder (+ mpgParser, Cmd(..), cmdToBS,+ Msg(..), Id3(..), Status(..), Frame(..),+) where++import Base++import Data.ByteString.Char8 qualified as P+import Data.ByteString.UTF8 qualified as UTF8++------------------------------------------------------------------------+-- Send commands to mpg123++data Cmd = Load ByteString | Jump Int | Pause | Quit++cmdToBS :: Cmd -> ByteString+cmdToBS (Load f) = "L " <> f+cmdToBS (Jump i) = "J " <> P.pack (show i) -- can be relative with +/-; not used here+cmdToBS Pause = "P" -- (un)pauses+cmdToBS Quit = "Q"++------------------------------------------------------------------------+-- Receive messages from mpg123++data Msg = I !Id3+ | S {-# UNPACK #-} !ByteString+ | F {-# UNPACK #-} !Frame+ | P !Status+ deriving stock (Eq, Show)++-- ID3 info+data Id3 = Id3+ { id3title :: !ByteString+ , id3artist :: !ByteString+ , id3album :: !ByteString+ , id3str :: !ByteString+ -- , year :: Maybe ByteString+ -- , genre :: Maybe ByteString }+ } deriving stock (Eq, Show)++-- Frame decoding status updates (once per frame).+-- Current-frame and frames-remaining are integers; current-time and+-- time-remaining floating point numbers with two decimal places.+data Frame = Frame {+ currentFrame :: !Int,+ framesLeft :: !Int,+ currentTime :: !(Fixed E2),+ timeLeft :: !(Fixed E2)+ } deriving stock (Eq, Show)++-- Stop/pause status.+data Status = Stopped | Paused | Playing+ deriving stock (Eq, Show)++-- | Strip leading and trailing whitespace.+trim :: ByteString -> ByteString+trim = P.dropWhileEnd isSpace . P.dropSpace++readPS :: ByteString -> Maybe Int+readPS = fmap fst . P.readInt++doP :: ByteString -> Maybe Msg+doP s = do+ (p, _) <- P.uncons s+ case p of+ '0' -> pure $ P Stopped+ '1' -> pure $ P Paused+ '2' -> pure $ P Playing+ _ -> Nothing -- don't need P 3 at end of song++-- Frame decoding status updates (once per frame).+doF :: ByteString -> Maybe Msg+doF s = do+ f0 : f1 : f2 : f3 : _ <- pure $ P.split ' ' s+ currentFrame <- readPS f0+ framesLeft <- readPS f1+ currentTime <- readMaybe $ P.unpack f2+ timeLeft <- max 0 <$> readMaybe (P.unpack f3)+ pure $ F Frame { currentFrame, framesLeft, currentTime, timeLeft }++-- Info about mp3 file after loading.+-- Breakdown from mpg123 README.remote (as numbers):+-- 0 = mpeg type (string)+-- 1 = layer (int)+-- 2 = sampling frequency (int)+-- 3 = mode (string)+-- 4 = mode extension (int)+-- 5 = framesize (int)+-- 6 = stereo (int)+-- 7 = copyright (int)+-- 8 = error protection (int)+-- 9 = emphasis (int)+-- 10 = bitrate (int)+-- 11 = extension (int)+doS :: ByteString -> Maybe Msg+doS s = do+ let fs = P.split ' ' s+ guard $ length fs >= 11+ hz <- readPS $ fs !! 2+ pure $ S $ mconcat [+ "mpeg ", fs !! 0, " ", fs !! 10, "kb/s ",+ P.pack $ show $ hz `div` 1000, "kHz"]++-- Track info if ID fields are in the file, otherwise file name.+doI :: ByteString -> Maybe Msg+doI s = I <$> do+ ("ID3:", info) <- pure $ P.splitAt 4 s+ let id3 = parseId3 info+ guard $ not $ P.null $ id3title id3 -- title sometimes empty+ pure id3++-- Format: title (30), author (30), album (30), year (4), comment (30), genre+-- We currently only use the first three.+parseId3 :: ByteString -> Id3+parseId3 = toId . cut where+ cut f | P.null f = []+ | True = let (a, xs) = P.splitAt 30 f in normalise a : cut xs+ toId ls = Id3 (arg 0) (arg 1) (arg 2) $ mconcat $ intersperse " : "+ $ filter (not . P.null) [arg 1, arg 2, arg 0]+ where arg = fromMaybe "" . (ls !?)++-- | Strip spaces, and if seeming ISO-8859-1 convert to UTF-8+normalise :: ByteString -> ByteString+normalise raw =+ let bs = trim raw+ in if UTF8.replacement_char `elem` UTF8.toString bs+ then UTF8.fromString $ P.unpack bs+ else bs++-- Parse line; on failure, return Just only if error to report.+mpgParser :: ByteString -> Either (Maybe String) Msg+mpgParser line = do+ -- bad packets are generally just \n in ID3 (and not of interest anyway)+ let quiet = maybe (Left Nothing) pure+ code <- quiet do+ '@' : c : ' ' : _ <- pure $ P.unpack line+ pure c+ let m = P.drop 3 line+ case code of+ 'I' -> quiet $ doI m+ 'S' -> quiet $ doS m+ 'F' -> quiet $ doF m+ 'P' -> quiet $ doP m+ 'E' -> Left $ Just $ P.unpack m+ _ -> quiet Nothing+
Keyboard.hs view
@@ -3,11 +3,12 @@ -- Copyright (c) 2019, 2023-2026 Galen Huntington -- SPDX-License-Identifier: GPL-2.0-or-later -module Keyboard (unkey, charToKey, Key(..)) where+module Keyboard (unkey, charToKey, Key(..), historyKeys) where import Base -import qualified Data.Map.Strict as M+import Data.Map.Strict qualified as M+import Data.Sequence qualified as Seq import UI.HSCurses.Curses (Key(..), decodeKey) ------------------------------------------------------------------------@@ -28,4 +29,7 @@ unkey :: Key -> Char unkey k = fromMaybe '\0' $ M.lookup k keyCharMap++historyKeys :: Seq Char+historyKeys = Seq.fromList $ ['0'..'9'] ++ ['a'..'z'] ++ filter (/='H') ['A'..'Z']
Keymap.hs view
@@ -16,14 +16,14 @@ import Core import Config (package)-import Keyboard (unkey, charToKey, Key(..))+import Keyboard (unkey, charToKey, Key(..), historyKeys) import State (getsHS, modifyHS_, KeysHelp, Modal(..), HState(..)) import Style (defaultSty, StringA(Fast))-import qualified UI (getKey, resetui)+import UI qualified (getKey, resetui) -import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.UTF8 as UTF8-import qualified Data.Map.Strict as M+import Data.ByteString.Char8 qualified as P+import Data.ByteString.UTF8 qualified as UTF8+import Data.Map.Strict qualified as M ------------------------------------------------------------------------@@ -47,9 +47,9 @@ mainMode :: KeyMap mainMode = KeyMap \c -> getsHS modal >>= \case - Just ExitModal -> case c of- 'y' -> shutdown Nothing $> undefined -- shutdown never returns- _ -> closeModal $> mainMode+ Just ExitModal+ | c `elem` ['y', 'Y', '\^C'] -> shutdown Nothing $> undefined+ | True -> closeModal $> mainMode Just (HistModal hist) -> do for_ (M.lookup c historyKeyMap >>= (hist !?)) (jump . fst . snd)@@ -60,17 +60,17 @@ toggleFocus hist <- getsHS searchHist searchMode c $ Zipper "" hist []- | c == 'q' ->+ | c `elem` ['q', '\^C'] -> forcePause *> setsModal (const $ Just ExitModal) $> mainMode | c `elem` ['H', ';'] -> showHist $> mainMode | c >= '1' && c <= '9' ->- jumpRel (0.1 * fromIntegral (fromEnum c - 48)) $> mainMode+ jumpRel (fromIntegral (fromEnum c - 48) / 10) $> mainMode | True -> sequence_ (M.lookup c keyMap) $> mainMode historyKeyMap :: M.Map Char Int-historyKeyMap = M.fromList $ zip (['0'..'9'] ++ ['a'..'z']) [0..]+historyKeyMap = M.fromList $ zip (toList historyKeys) [0..] ------------------------------------------------------------------------@@ -86,13 +86,15 @@ step z = renderSearch stype z $> KeyMap (`dispatch` z) dispatch c z- | c == '\ESC' = clearMessage *> leave+ | c `elem` ['\ESC', '\^C']+ = clearMessage *> 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+ | c < ' ' || c > '\255'+ = step z -- ignore other special keys | otherwise = step $ zipEdit (++ [c]) z where k = charToKey c
− Lexer.hs
@@ -1,114 +0,0 @@--- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2008, 2019-2026 Galen Huntington--- SPDX-License-Identifier: GPL-2.0-or-later---- Lexer for mpg123 messages--module Lexer ( mpgParser ) where--import Base-import Syntax (Msg(..), Status(..), Frame(..), Info(..), Id3(..), Tag(..))--import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.UTF8 as UTF8------------------------------------------------------------------------------ | Strip leading and trailing whitespace.-trim :: ByteString -> ByteString-trim = P.dropWhileEnd isSpace . P.dropSpace--readPS :: ByteString -> Maybe Int-readPS = fmap fst . P.readInt--doP :: ByteString -> Maybe Msg-doP s = do- (p, _) <- P.uncons s- case p of- '0' -> pure $ S Stopped- '1' -> pure $ S Paused- '2' -> pure $ S Playing- -- recent mpg123 outputs 3 for end of song; don't need- _ -> Nothing---- Frame decoding status updates (once per frame).-doF :: ByteString -> Maybe Msg-doF s = do- f0 : f1 : f2 : f3 : _ <- pure $ P.split ' ' s- currentFrame <- readPS f0- framesLeft <- readPS f1- currentTime <- readMaybe $ P.unpack f2- timeLeft <- max 0 <$> readMaybe (P.unpack f3)- pure $ R Frame { currentFrame , framesLeft, currentTime, timeLeft }---- Info about mp3 file after loading.--- Breakdown from mpg123 README.remote (as numbers):--- 0 = mpeg type (string)--- 1 = layer (int)--- 2 = sampling frequency (int)--- 3 = mode (string)--- 4 = mode extension (int)--- 5 = framesize (int)--- 6 = stereo (int)--- 7 = copyright (int)--- 8 = error protection (int)--- 9 = emphasis (int)--- 10 = bitrate (int)--- 11 = extension (int)-doS :: ByteString -> Maybe Msg-doS s = do- let fs = P.split ' ' s- guard $ length fs >= 11- hz <- readPS $ fs !! 2- pure $ I $ Info $ mconcat [- "mpeg ", fs !! 0, " ", fs !! 10, "kbit/s ",- P.pack $ show $ hz `div` 1000, "kHz"]---- Track info if ID fields are in the file, otherwise file name.-doI :: ByteString -> Maybe Msg-doI s = F <$> do- ("ID3:", info) <- pure $ P.splitAt 4 s- let id3 = parseId3 info- guard $ not $ P.null $ id3title id3 -- title sometimes empty- pure id3---- Format: title (30), author (30), album (30), year (4), comment (30), genre--- We currently only use the first three.-parseId3 :: ByteString -> Id3-parseId3 = toId . cut where- cut f | P.null f = []- | True = let (a, xs) = P.splitAt 30 f in normalise a : cut xs- toId ls = Id3 (arg 0) (arg 1) (arg 2) $ mconcat $ intersperse " : "- $ filter (not . P.null) [arg 1, arg 2, arg 0]- where arg = fromMaybe "" . (ls !?)---- | Strip spaces, and if seeming ISO-8859-1 convert to UTF-8-normalise :: ByteString -> ByteString-normalise raw =- let bs = trim raw- in if UTF8.replacement_char `elem` UTF8.toString bs- then UTF8.fromString $ P.unpack bs- else bs------------------------------------------------------------------------------ Parse line; on failure, return Just only if error to report.-mpgParser :: ByteString -> Either (Maybe String) Msg-mpgParser line = do- -- bad packets are generally just \n in ID3 (and not of interest anyway)- let quiet = maybe (Left Nothing) pure-- code <- quiet do- '@' : c : ' ' : _ <- pure $ P.unpack line- pure c-- let m = P.drop 3 line- case code of- 'R' -> pure $ T Tag- 'I' -> quiet $ doI m- 'S' -> quiet $ doS m- 'F' -> quiet $ doF m- 'P' -> quiet $ doP m- 'E' -> Left $ Just $ P.unpack m- _ -> quiet Nothing-
+ Playlist.hs view
@@ -0,0 +1,131 @@+-- Copyright (c) 2005-8 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- Copyright (c) 2019-2020, 2025-2026 Galen Huntington+-- SPDX-License-Identifier: GPL-2.0-or-later++module Playlist (module Playlist, RawFilePath) where++import Base++import Data.ByteString.Char8 qualified as P+import Data.Map.Strict qualified as M++import Data.Array+import System.Posix.FilePath+import System.Posix.Files.ByteString (getFileStatus, isDirectory, fileAccess)+import System.Posix.Directory.Traversals (getDirectoryContents)+++-- | A filesystem hierarchy is flattened to just the end nodes+type DirArray = Array Int Dir++-- | The complete list of .mp3 files+type FileArray = Array Int File++-- | A directory entry is the directory name, and a list of bound+-- indicies into the Files array.+data Dir =+ Dir { dname :: !RawFilePath -- ^ directory name+ , dsize :: !Int -- ^ number of file entries+ , dlo :: !Int -- ^ index of first entry+ , dhi :: !Int } -- ^ index of last entry++-- Most data is allocated in this structure+data File =+ File { fbase :: !RawFilePath -- ^ basename of file+ , fdir :: !Int } -- ^ index of Dir entry ++data Playlist = Playlist !DirArray !FileArray++--+-- | Given the start directories, populate the dirs and files arrays+--+buildPlaylist :: [RawFilePath] -> IO Playlist+buildPlaylist fs = do+ -- note we will lose the ordering of files given on cmd line.+ (os, dirs) <- catch @SomeException (sift fs)+ \e -> print e *> exitWith (ExitFailure 1)++ let loop [] = pure []+ loop (a:xs) = do+ (m, ds) <- expandDir a+ ms <- loop $ ds ++ xs -- add to work list+ pure $ m : ms++ ms' <- catMaybes <$> loop dirs++ let extras = merge . doOrphans $ os+ ms = ms' ++ extras++ let (_,n,dirls,filels) = foldl' make (0,0,[],[]) ms+ dirsArray = listArray (0,length dirls - 1) (reverse dirls)+ fileArray = listArray (0, n-1) (reverse filels)++ pure $! Playlist dirsArray fileArray++-- | Is the playlist empty?+isEmpty :: Playlist -> Bool+isEmpty (Playlist _ files) = null files++-- | Create nodes based on dirname for orphan files on cmdline+doOrphans :: [RawFilePath] -> [(RawFilePath, [RawFilePath])]+doOrphans = map \f -> (takeDirectory f, [takeFileName f])++-- | Merge entries with the same root node into a single node+merge :: [(RawFilePath, [RawFilePath])] -> [(RawFilePath, [RawFilePath])]+merge = M.assocs . M.fromListWith (flip (++))++-- | fold builder, for generating Dirs and Files+make :: (Int,Int,[Dir],[File]) -> (RawFilePath,[RawFilePath]) -> (Int,Int,[Dir],[File])+make (i,n,acc1,acc2) (d,fs) =+ let (dir, n') = listToDir n d fs+ fs'= map makeFile fs+ in (i+1, n', dir:acc1, reverse fs' ++ acc2)+ where+ makeFile f = File (takeFileName f) i++------------------------------------------------------------------------++-- | Expand a single directory into a maybe a pair of the dir name and any files+-- Return any extra directories to search in+--+-- Assumes no evil sym links+--+expandDir :: RawFilePath -> IO (Maybe (RawFilePath, [RawFilePath]), [RawFilePath])+expandDir !f = do+ ls <- map (f </>) . sort . filter notHidden . map snd+ <$> getDirectoryContents f+ (fs', ds) <- sift ls+ let fs = filter isMp3 fs'+ v = guard (not $ null fs) *> Just (f, fs)+ pure (v, ds)+ where+ notHidden = not . P.isPrefixOf "."+ isMp3 = (== ".mp3") . P.map toLower . takeExtension++-- | Given an index into the files array, a directory name, and+-- a list of files in that dir, build a Dir and return the next index+-- into the array+listToDir :: Int -> RawFilePath -> [RawFilePath] -> (Dir, Int)+listToDir n d fs = (dir, n') where+ dir = Dir+ { dname = dropTrailingPathSeparator d+ , dsize = len+ , dlo = n+ , dhi = n + len - 1+ }+ len = length fs+ n' = n + len++-- | Break a pair of sublists of files and directories, filtering+-- out ones without permission.+sift :: [RawFilePath] -> IO ([RawFilePath], [RawFilePath])+sift [] = pure ([], [])+sift (p:ps) = do+ it@(fs,ds) <- sift ps+ isDir <- isDirectory <$> getFileStatus p+ perm <- fileAccess p True False isDir+ pure if+ | not perm -> it+ | isDir -> (fs, p:ds)+ | True -> (p:fs, ds)+
README.md view
@@ -20,7 +20,7 @@ regeneration of a `configure` file (now gone). * The code has been updated to compile under recent GHC (tested-through 9.14; minimum supported 9.0) and libraries. This required+through 9.14; minimum supported 9.2) and libraries. This required rewriting or entirely replacing large sections, mainly low-level optimizations. @@ -59,10 +59,7 @@ Either `cabal install` or `stack install` will build a binary. You will need to have `mpg123` installed, which is free software and-widely available in package managers. Alternatively, `mpg321` can-be used by compiling with the `-DMPG321` option. In my experience,-the latter worked better, but it too is abandoned, with no update-since 2012, and is no longer available on many systems.+widely available in package managers. The build depends on the package `hscurses`, which in turn requires curses dev files. In Ubuntu/Debian, for example, these can be obtained
State.hs view
@@ -9,17 +9,15 @@ import Base -import Syntax (Status, Mode, Frame, Info, Id3, Pretty(ppr))-import Tree (FileArray, DirArray)+import Decoder (Status, Frame, Id3, Cmd, cmdToBS)+import Playlist (FileArray, DirArray) import Style (StringA, UIStyle) import Data.ByteString (hPut)-import Data.Sequence (Seq) import System.Clock (TimeSpec(..)) import System.IO (hFlush) import System.Process (ProcessHandle) import System.Random (StdGen)-import Text.Regex.PCRE.Light (Regex) -- | Player state@@ -34,26 +32,29 @@ , current :: !Int -- currently playing mp3 , cursor :: !Int -- mp3 under the cursor , clock :: !(Maybe Frame) -- current clock value- , clockUpdate :: !Bool , 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+ , info :: !(Maybe ByteString) -- mp3 info , status :: !Status , minibuffer :: !StringA -- contents of minibuffer , modal :: !(Maybe Modal) -- modal visible , miniFocused :: !Bool -- is the mini buffer focused? , mode :: !Mode , uptime :: !ByteString- , regex :: !(Maybe (Regex,Bool)) -- most recent search pattern and direction+ , searchFw :: !Bool -- active search direction , searchHist :: ![String] , exiting :: !Bool -- let mpg123 die? , playHist :: !(Seq (TimeSpec, Int))+ , histSize :: Int , config :: !UIStyle } +data Mode = Once | Loop | Random | Single+ deriving stock (Eq, Bounded, Enum, Show, Read)+ -- Each is (timestamp-string, (song-index, song-name)). type HistDisplay = [(ByteString, (Int, ByteString))] @@ -79,19 +80,15 @@ ------------------------------------------------------------------------ -- The decoder. -data Mpg = Mpg- { writeh :: !Handle- , readh :: !Handle- , errh :: !Handle- }+data Mpg = Mpg { errh :: !Handle, writeh :: !Handle } 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+sendMpg :: Cmd -> IO ()+sendMpg c = withMVar mpg $ (. writeh) \h ->+ hPut h (cmdToBS c) *> hPut h "\n" *> hFlush h ------------------------------------------------------------------------ -- state accessor functions
Style.hs view
@@ -9,8 +9,8 @@ module Style where import Base-import qualified UI.HSCurses.Curses as Curses-import qualified Data.Map as M+import UI.HSCurses.Curses qualified as Curses+import Data.Map qualified as M ------------------------------------------------------------------------
− Syntax.hs
@@ -1,107 +0,0 @@--- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- 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--- type safe messaging, and parsing of results-----module Syntax where--import Base--import qualified Data.ByteString.Char8 as P-------------------------------------------------------------------------------- Values we may print out:---- Loads and starts playing <file>----newtype Load = Load ByteString--instance Pretty Load where- ppr (Load f) = mconcat ["LOAD ", f]---- If '+' or '-' is specified, jumps <frames> frames forward, or backwards,--- respectively, in the the mp3 file. If neither is specifies, jumps to--- absolute frame <frames> in the mp3 file.-newtype Jump = Jump Int--instance Pretty Jump where- ppr (Jump i) = mconcat ["JUMP ", P.pack . show $ i]---- Pauses the playback of the mp3 file; if already paused, restarts playback.-data Pause = Pause--instance Pretty Pause where- ppr Pause = "PAUSE"---- Quits mpg123.-data Quit = Quit--instance Pretty Quit where- ppr Quit = "QUIT"-------------------------------------------------------------------------------- Values we may have to read back in---- mpg123 tagline. Output at startup.-data Tag = Tag- deriving stock (Eq, Show)---- ID3 info-data Id3 = Id3- { id3title :: !ByteString- , id3artist :: !ByteString- , id3album :: !ByteString- , id3str :: !ByteString- }- deriving stock (Eq, Show)---- , year :: Maybe ByteString--- , genre :: Maybe ByteString }----- mp3 file info; TODO maybe don't need this newtype at all?-newtype Info = Info { userinfo :: ByteString }- deriving stock (Eq, Show)---- Frame decoding status updates (once per frame).--- Current-frame and frames-remaining are integers; current-time and--- time-remaining floating point numbers with two decimal places.-data Frame = Frame {- currentFrame :: !Int,- framesLeft :: !Int,- currentTime :: !(Fixed E2),- timeLeft :: !(Fixed E2)- }- deriving stock (Eq, Show)---- Stop/pause status.-data Status = Stopped | Paused | Playing- deriving stock (Eq, Show)--data Mode = Once | Loop | Random | Single- deriving stock (Eq, Bounded, Enum, Show, Read)--------------------------------------------------------------------------------- a pretty printing class----class Pretty a where- ppr :: a -> ByteString------- And a wrapper type ----data Msg = T {-# UNPACK #-} !Tag- | F !Id3- | I {-# UNPACK #-} !Info- | R {-# UNPACK #-} !Frame- | S !Status- deriving stock (Eq, Show)-
− Tree.hs
@@ -1,135 +0,0 @@--- Copyright (c) 2005-8 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019-2020, 2025-2026 Galen Huntington--- SPDX-License-Identifier: GPL-2.0-or-later------- functions for manipulating file trees-----module Tree (module Tree, RawFilePath) where--import Base--import qualified Data.ByteString.Char8 as P-import qualified Data.Map.Strict as M--import Data.Array-import System.Posix.FilePath-import System.Posix.Files.ByteString (getFileStatus, isDirectory, fileAccess)-import System.Posix.Directory.Traversals (getDirectoryContents)----- | A filesystem hierarchy is flattened to just the end nodes-type DirArray = Array Int Dir---- | The complete list of .mp3 files-type FileArray = Array Int File---- | A directory entry is the directory name, and a list of bound--- indicies into the Files array.-data Dir =- Dir { dname :: !RawFilePath -- ^ directory name- , dsize :: !Int -- ^ number of file entries- , dlo :: !Int -- ^ index of first entry- , dhi :: !Int } -- ^ index of last entry---- Most data is allocated in this structure-data File =- File { fbase :: !RawFilePath -- ^ basename of file- , fdir :: !Int } -- ^ index of Dir entry --data Tree = Tree !DirArray !FileArray------- | Given the start directories, populate the dirs and files arrays----buildTree :: [RawFilePath] -> IO Tree-buildTree fs = do- -- note we will lose the ordering of files given on cmd line.- (os, dirs) <- catch @SomeException (sift fs)- \e -> print e *> exitWith (ExitFailure 1)-- let loop [] = pure []- loop (a:xs) = do- (m, ds) <- expandDir a- ms <- loop $ ds ++ xs -- add to work list- pure $ m : ms-- ms' <- catMaybes <$> loop dirs-- let extras = merge . doOrphans $ os- ms = ms' ++ extras-- let (_,n,dirls,filels) = foldl' make (0,0,[],[]) ms- dirsArray = listArray (0,length dirls - 1) (reverse dirls)- fileArray = listArray (0, n-1) (reverse filels)-- pure $! Tree dirsArray fileArray---- | Is the tree empty?-isEmpty :: Tree -> Bool-isEmpty (Tree _ files) = null files---- | Create nodes based on dirname for orphan files on cmdline-doOrphans :: [RawFilePath] -> [(RawFilePath, [RawFilePath])]-doOrphans = map \f -> (takeDirectory f, [takeFileName f])---- | Merge entries with the same root node into a single node-merge :: [(RawFilePath, [RawFilePath])] -> [(RawFilePath, [RawFilePath])]-merge = M.assocs . M.fromListWith (flip (++))---- | fold builder, for generating Dirs and Files-make :: (Int,Int,[Dir],[File]) -> (RawFilePath,[RawFilePath]) -> (Int,Int,[Dir],[File])-make (i,n,acc1,acc2) (d,fs) =- let (dir, n') = listToDir n d fs- fs'= map makeFile fs- in (i+1, n', dir:acc1, reverse fs' ++ acc2)- where- makeFile f = File (takeFileName f) i------------------------------------------------------------------------------ | Expand a single directory into a maybe a pair of the dir name and any files--- Return any extra directories to search in------ Assumes no evil sym links----expandDir :: RawFilePath -> IO (Maybe (RawFilePath, [RawFilePath]), [RawFilePath])-expandDir !f = do- ls <- map (f </>) . sort . filter notHidden . map snd- <$> getDirectoryContents f- (fs', ds) <- sift ls- let fs = filter isMp3 fs'- v = guard (not $ null fs) *> Just (f, fs)- pure (v, ds)- where- notHidden = not . P.isPrefixOf "."- isMp3 = (== ".mp3") . P.map toLower . takeExtension---- | Given an index into the files array, a directory name, and--- a list of files in that dir, build a Dir and return the next index--- into the array-listToDir :: Int -> RawFilePath -> [RawFilePath] -> (Dir, Int)-listToDir n d fs = (dir, n') where- dir = Dir- { dname = dropTrailingPathSeparator d- , dsize = len- , dlo = n- , dhi = n + len - 1- }- len = length fs- n' = n + len---- | Break a pair of sublists of files and directories, filtering--- out ones without permission.-sift :: [RawFilePath] -> IO ([RawFilePath], [RawFilePath])-sift [] = pure ([], [])-sift (p:ps) = do- it@(fs,ds) <- sift ps- isDir <- isDirectory <$> getFileStatus p- perm <- fileAccess p True False isDir- pure if- | not perm -> it- | isDir -> (fs, p:ds)- | True -> (p:fs, ds)-
UI.hs view
@@ -21,13 +21,13 @@ import Base import Style-import Tree (File(fdir, fbase), Dir(dname))+import Playlist (File(fdir, fbase), Dir(dname)) import State-import Syntax+import Decoder import Config import Width (displayWidth, toMaxWidth, toWidth)-import qualified UI.HSCurses.Curses as Curses-import Keyboard (unkey, charToKey)+import UI.HSCurses.Curses qualified as Curses+import Keyboard (unkey, charToKey, historyKeys) import Data.Array ((!), bounds, Array) import Data.Array.Base (unsafeAt)@@ -39,9 +39,9 @@ import Foreign.C.Types import Foreign.C.Error (Errno(..), getErrno) -import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.Unsafe as P-import qualified Data.ByteString.UTF8 as UTF8+import Data.ByteString.Char8 qualified as P+import Data.ByteString.Unsafe qualified as P+import Data.ByteString.UTF8 qualified as UTF8 -- Write u-strings like it's Python 2.@@ -170,7 +170,7 @@ ------------------------------------------------------------------------ --- | The three lines of the play-mode widget.+-- | The three lines of the play info widget. playScreen :: DrawData -> [StringA] playScreen dd = [pPlaying dd, progressBar dd, pTimes dd] @@ -178,7 +178,7 @@ -- | Info about the current track pPlaying :: DrawData -> StringA-pPlaying dd = FancyS $ map (, defaultSty) $ " " : line where+pPlaying dd = flip Fast defaultSty $ " " <> mconcat line where x = sizeW $ drawSize dd a = pId3 dd b = pInfo dd@@ -193,15 +193,11 @@ pId3 :: DrawData -> ByteString pId3 DD{drawState=st} = case id3 st of Just i -> id3str i- Nothing -> case size st of- 0 -> "(empty)"- _ -> fbase $ music st ! current st+ Nothing -> fbase $ music st ! current st -- | mp3 information pInfo :: DrawData -> ByteString-pInfo DD{drawState=st} = case info st of- Nothing -> "(empty)"- Just i -> userinfo i+pInfo DD{drawState=st} = fromMaybe "" $ info st commonModalWidth :: Int -> Int commonModalWidth w = max (min w 3) $ round $ fromIntegral w * (0.8::Float)@@ -235,13 +231,15 @@ ------------------------------------------------------------------------ histModal :: HistDisplay -> ModalMaker+histModal [] _ = let s = " No history " in (P.length s, [s]) histModal hist swd = do let wd = commonModalWidth swd- mtlen = maximum $ 0 : map (displayWidth . 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))) ->+ (wd, [ let tstr = toMaxWidth tlen $ P.replicate (tlen - displayWidth time) ' ' <> time in mconcat [" ", P.singleton c, " ", tstr, " ", song]+ | (c, (time, (_, song))) <- zip (toList historyKeys ++ repeat ' ') hist ]) ------------------------------------------------------------------------ @@ -252,24 +250,26 @@ ------------------------------------------------------------------------ +showClock :: Fixed E2 -> ByteString+showClock t =+ let m, si, sd :: Int+ (m, s) = t `divMod'` 60+ si = floor s+ sd = floor (s*10) `mod` 10+ in P.pack $ printf "%d:%02d.%d" m si sd+ -- | The time used and time left pTimes :: DrawData -> StringA-pTimes DD { drawFrame=Just Frame {..}, drawSize=Size{sizeW=x} } =- FancyS $ map (, defaultSty)- if x - 4 < P.length elapsed- then [" "]- else [" ", elapsed]- ++ (guard (distance > 0) *> [gap, remaining])+pTimes DD { drawFrame=Just Frame {..}, drawSize=Size{sizeW=w} } =+ flip Fast defaultSty $ if w - 4 < P.length elapsed+ then ""+ else mconcat $ [" ", elapsed] ++ [gap <> "-" <> remaining | distance > 0] where- elapsed = P.pack $ printf "%d:%02d" l_m l_s- remaining = P.pack $ printf "-%d:%02d" r_m r_s- (l_m, l_s) = toMS currentTime- (r_m, r_s) = toMS timeLeft- gap = spaces distance- distance = x - 4 - P.length elapsed - P.length remaining- toMS :: RealFrac a => a -> (Int, Int)- toMS = flip quotRem 60 . floor-pTimes _ = Fast (spaces 5) defaultSty+ elapsed = showClock currentTime+ remaining = showClock timeLeft+ gap = spaces distance+ distance = w - 5 - P.length elapsed - P.length remaining+pTimes _ = Fast "" defaultSty ------------------------------------------------------------------------ @@ -304,74 +304,59 @@ pTime :: DrawData -> ByteString pTime = uptime . drawState --- | Play mode-pMode :: DrawData -> String-pMode dd = case status (drawState dd) of+-- | Play state+pState :: DrawData -> String+pState dd = case status (drawState dd) of Stopped -> "◼" Paused -> "⏸" Playing -> "▶" --- | Loop, normal, or random-pMode2 :: DrawData -> String-pMode2 dd = case mode (drawState dd) of- Random -> "rand"- Loop -> "loop"- Once -> "once"- Single -> "sing"+-- | Play mode+pMode :: DrawData -> String+pMode dd = take 4 $ map toLower $ show $ mode $ drawState dd ------------------------------------------------------------------------ --- | The two play-mode glyphs (e.g. "▶ rand") rendered together.-playModes :: DrawData -> String-playModes dd = pMode dd ++ ' ' : pMode2 dd---- | "x/n dir(s) y/m file(s)" cursor position read-out.+-- | "x/n dirs y/m files" cursor position read-out. playInfo :: DrawData -> ByteString playInfo dd = mconcat- -- TODO pregenerate as template [ spaces (P.length numd - P.length curd)- , curd, "/", numd, " dir", onPlural (snd . bounds $ folders st) "" "s"- , " "- , spaces (P.length numf - P.length curf)- , curf, "/", numf, " file", onPlural (size st) "" "s"+ , curd, "/", numd, " dirs"+ , spaces (1 + P.length numf - P.length curf)+ , curf, "/", numf, " files" ] where st = drawState dd tobs = P.pack . show- onPlural 1 s _ = s- onPlural _ _ p = p curf = tobs $ 1 + cursor st numf = tobs $ size st mydir = fdir $ music st ! cursor st curd = tobs $ 1 + mydir- numd = tobs $ 1 + snd (bounds $ folders st)+ numd = tobs $ length $ folders st --- | The top title bar: cursor position + play modes + uptime + version.+-- | The top title bar: cursor position + play indicator + uptime + version. playTitle :: DrawData -> StringA playTitle dd =- FancyS $ map (, hl)- if gap >= 2- then [mconcat [" ", inf, spaces gapl], modesBS,- mconcat [spaces gapr, time, " ", ver, " "]]- else let gap' = x - modlen; gapl' = gap' `div` 2+ flip Fast hl $ mconcat if gap >= 2+ then [" ", inf, spaces gapl, indic, spaces gapr, time, " ", ver, " "]+ else let gap' = x - indicl; gapl' = gap' `div` 2 in if gap' >= 2- then [spaces gapl', modesBS, spaces $ gap' - gapl']- else [" ", u $ take (x-2) modes, " "]+ then [spaces gapl', indic, spaces $ gap' - gapl']+ else [" ", P.take (x-2) indic, " "] where inf = playInfo dd time = pTime dd- modes = playModes dd+ indic = u $ pState dd ++ ' ' : pMode dd ver = pVersion- modesBS = u modes x = sizeW $ drawSize dd lsize = 1 + P.length inf rsize = 2 + P.length time + P.length ver- side = (x - modlen) `div` 2- gap = x - modlen - lsize - rsize+ side = (x - indicl) `div` 2+ gap = x - indicl - lsize - rsize gapl = 1 `max` ((side - lsize) `min` (gap - 1)) gapr = gap - gapl- modlen = 6 -- length modes+ indicl = 6 -- length indic hl = titlebar . config $ drawState dd -- | The scrolling playlist (title + visible tracks + minibuffer).@@ -413,35 +398,29 @@ indent = (round $ (0.334 :: Float) * fromIntegral x) :: Int - 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, [s])- where- f sty = (m, sty,- [s, spaces (x - indent - 1 - displayWidth s)])+ (sty1, sty2, sty3) = (selected cs, cursors cs, combined cs)+ where cs = config st - sty1 = selected . config $ st- sty2 = cursors . config $ st- sty3 = combined . config $ st+ color :: ((Maybe Int, ByteString), Int)+ -> (Maybe Int, (Style, [ByteString]))+ color ((m, s), i) = (m,) case (i == select, i == playing) of+ (True, True) -> f sty3+ (True, _) -> f sty2+ (_ , True) -> f sty1+ _ -> (defaultSty, [s])+ where+ f sty = (sty, [s, spaces (x - indent - 1 - displayWidth s)]) - drawIt :: (Maybe Int, Style, [ByteString]) -> StringA- drawIt (Nothing, sty, v) =+ drawIt :: (Maybe Int, (Style, [ByteString])) -> StringA+ drawIt (Nothing, (sty, v)) = FancyS $ map (, sty) $ spaces (1 + indent) : v-- drawIt (Just i, sty, v) = FancyS+ drawIt (Just i, (sty, v)) = FancyS $ (d, sty') : (spaces (indent + 1 - displayWidth d), sty') : map (, sty) v where sty' = if sty == sty2 || sty == sty3 then sty2 else sty1- d = toMaxWidth (indent - 1) $ takeFileName- $ case size st of- 0 -> "(empty)"- _ -> dname $ folders st ! i+ d = toMaxWidth (indent - 1) $ takeFileName $ dname $ folders st ! i ------------------------------------------------------------------------ @@ -459,7 +438,6 @@ drawLine $ progressBar dd Curses.wMove Curses.stdScr 2 0 -- hardcoded! drawLine $ pTimes dd- when (h < 45) $ renderModals st (Size h w) -- small screen modals paint over clock ------------------------------------------------------------------------ -- | General modal renderer.@@ -467,11 +445,11 @@ renderModal st (Size h w) mkr = do let (mw, modal') = mkr w hoffset = max 0 $ (w - mw) `div` 2- mlines = min h $ length modal'- voffset = (h - mlines) `div` 2+ vislines = (h - 5) `min` length modal'+ voffset = ((h - vislines) `div` 2) `max` 4 sty = modals $ config st Curses.wMove Curses.stdScr voffset hoffset- for_ (take mlines modal') \t -> do+ for_ (take vislines modal') \t -> do drawLine $ Fast (toWidth mw t) sty (y', _) <- Curses.getYX Curses.stdScr Curses.wMove Curses.stdScr (y'+1) hoffset@@ -485,9 +463,7 @@ ExitModal -> exitModal --------------------------------------------------------------------------- -- | Draw the screen--- redraw :: Draw redraw = Draw $ discardErrors {- TODO what errors are discarded? -} do st <- getsHS id -- another refresh could be triggered?@@ -517,9 +493,7 @@ -- todo rendering bug here when deleting backwards in minibuffer --------------------------------------------------------------------------- -- | Draw a coloured (or not) string to the screen--- drawLine :: StringA -> IO () drawLine (Fast ps sty) = drawSegment ps sty drawLine (FancyS ls) = traverse_ (uncurry drawSegment) ls
Width.hs view
@@ -7,8 +7,8 @@ import Base -import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.UTF8 as UTF8+import Data.ByteString.Char8 qualified as P+import Data.ByteString.UTF8 qualified as UTF8 import Foreign.C.Types
app/Main.hs view
@@ -8,15 +8,14 @@ import Base import Core (start, shutdown, Options(..))-import qualified Config+import Config qualified import Keymap (keyLoop)-import Tree (buildTree, isEmpty)+import Playlist (buildPlaylist, isEmpty) -import System.IO (hPrint, stderr)-import System.Posix.Signals (installHandler, sigTERM, sigPIPE, sigINT, sigHUP- ,sigALRM, sigABRT, Handler(Ignore, Default, Catch))+import System.Posix.Signals (installHandler, Handler(Ignore, Default, Catch),+ sigTERM, sigPIPE, sigINT, sigHUP , sigALRM, sigABRT) -import qualified Data.ByteString.UTF8 as UTF8+import Data.ByteString.UTF8 qualified as UTF8 import Options.Applicative @@ -35,8 +34,7 @@ exitHandler :: IO () exitHandler = do releaseSignals -- in case shutdown itself gets stuck- catch @SomeException (shutdown Nothing) (hPrint stderr)- exitWith $ ExitFailure 1+ shutdown $ Just "Killed" releaseSignals :: IO () releaseSignals =@@ -56,6 +54,12 @@ <*> 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"))+ <*> optional (option (maybeReader prefixMatch) (+ long "mode" <> short 'm' <> metavar "MODE"+ <> help "Initial play mode (default: last selected, or once)"))+ <*> option auto (+ long "history" <> short 'h' <> metavar "NUM" <> value 61+ <> help "Size of play history, up to 61 selectable" <> showDefault) files = some $ argument (UTF8.fromString <$> str) (metavar "FILE|DIR...") parserInfo :: ParserInfo (Options, [ByteString])@@ -67,17 +71,25 @@ versionOpt = infoOption Config.versinfo (hidden <> long "version" <> short 'V' <> help "Show version information") +-- XXX should this have tests?+prefixMatch :: (Enum a, Bounded a, Show a) => String -> Maybe a+prefixMatch s =+ case [ x | x <- [minBound .. maxBound], s' `isPrefixOf` map toLower (show x) ] of+ [x] -> Just x+ _ -> Nothing+ where s' = map toLower s+ ------------------------------------------------------------------------ main :: IO () main = do (opts, args) <- customExecParser (prefs showHelpOnEmpty) parserInfo- tree <- buildTree args- when (isEmpty tree) $+ list <- buildPlaylist args+ when (isEmpty list) $ errorWithoutStackTrace "Error: No music files found." initSignals err <- either id absurd <$> try @SomeException do- start opts tree+ start opts list keyLoop shutdown $ Just $ "Error: " ++ show err
hmp3-ng.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hmp3-ng-version: 2.18.1+version: 2.19.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@@ -24,7 +24,7 @@ location: https://github.com/galenhuntington/hmp3-ng common opts- default-language: Haskell2010+ default-language: GHC2021 default-extensions: BlockArguments MultiWayIf@@ -33,18 +33,10 @@ -- In GHC2024 DerivingStrategies LambdaCase- -- In GHC2021 (soon!)- BangPatterns- GeneralizedNewtypeDeriving- NamedFieldPuns- NumericUnderscores- ScopedTypeVariables- StandaloneDeriving- TupleSections- TypeApplications ghc-options: -Wall+ -Wprepositive-qualified-module -funbox-strict-fields library@@ -54,13 +46,12 @@ Base Config Core+ Decoder Keyboard Keymap- Lexer+ Playlist State Style- Syntax- Tree UI Width @@ -75,7 +66,7 @@ build-depends: array,- base >=4.15 && <5,+ base >=4.16 && <5, bytestring >=0.10, clock, containers,@@ -83,11 +74,11 @@ filepath, hscurses, mtl,- pcre-light >=0.3, posix-paths, process, random,- unix >=2.7,+ regex-posix,+ unix >=2.8, utf8-string, executable hmp3@@ -97,7 +88,6 @@ ghc-options: -threaded build-depends: base,- bytestring, hmp3-ng, optparse-applicative, unix,@@ -109,11 +99,12 @@ main-is: Main.hs hs-source-dirs: test other-modules:+ BaseSpec ConfigSpec CoreSpec- LexerSpec+ DecoderSpec+ PlaylistSpec StyleSpec- TreeSpec WidthSpec build-depends:
+ test/BaseSpec.hs view
@@ -0,0 +1,30 @@+module BaseSpec (tests) where++import Data.ByteString.UTF8 qualified as UTF8++import Test.Tasty+import Test.Tasty.HUnit++import Base (matches)++tests :: TestTree+tests = testGroup "Base"+ [ testGroup "match"+ [ t True "exact" "foo" "fooBar"+ , t True "caseless" "FOO" "fooBar"+ , t False "invalid" "[" "any[thing"+ , t True "alt" "(foo|az)Q" "bazQux"+ , t True "dot" "o.a" "foobar"+ , t True "Unicode" "jör" "Björk"+ , t True "dot Unicode" "j.r" "Björk"+ , t True "Nordic case" "bør" "BØrnE"+ , t True "Greek case" "Λω" "ΦλΩα"+ , t True "dot CJK" "中.人" "中國人"+ ]+ ]+++t :: Bool -> String -> String -> String -> TestTree+t b tag pat str =+ testCase tag $ matches (UTF8.fromString pat) (UTF8.fromString str) @?= b+
+ test/DecoderSpec.hs view
@@ -0,0 +1,63 @@+module DecoderSpec (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import Data.ByteString.Char8 qualified as P++import Decoder++-- These exercise the helpers doX, 'trim', and 'normalise'.+tests :: TestTree+tests = testGroup "Lexer.mpgParser"+ [ testGroup "status (@P)"+ [ tc "@P 0" $ Right (P Stopped)+ , tc "@P 1" $ Right (P Paused)+ , tc "@P 2" $ Right (P Playing)+ , tc "@P 3" $ Left Nothing -- end-of-song marker: ignored (no double play)+ , tc "@P 9" $ Left Nothing -- unknown code+ , tc "@P " $ Left Nothing -- no payload+ ]+ , testGroup "frame (@F)"+ [ tc "@F 123 456 12.34 56.78" $ Right (F (Frame 123 456 12.34 56.78))+ , tc "@F 0 0 0.00 -1.00" $ Right (F (Frame 0 0 0.00 0)) -- timeLeft clamped+ , tc "@F 1 2 3.00" $ Left Nothing -- too few fields+ , tc "@F a b c d" $ Left Nothing -- non-numeric+ ]+ , testGroup "stream info (@S)"+ [ tc "@S 1.0 1 44100 stereo 0 0 2 0 0 0 128 0"+ $ Right (S "mpeg 1.0 128kb/s 44kHz")+ , tc "@S 1.0 1 44100" $ Left Nothing -- too few fields+ ]+ , testGroup "id3 (@I)" (let s = "n\195\182rmalise" in+ [ tcId3 ["Title"]+ $ Right (I (Id3 "Title" "" "" "Title"))+ , tcId3 ["Title", "Artist"]+ $ Right (I (Id3 "Title" "Artist" "" "Artist : Title"))+ , tcId3 [" Title", " Artist"]+ $ Right (I (Id3 "Title" "Artist" "" "Artist : Title"))+ , tcId3 ["Title", "Artist", "Album"]+ $ Right (I (Id3 "Title" "Artist" "Album" "Artist : Album : Title"))+ , tcId3 ["", "Artist"] $ Left Nothing -- blank title: skipped+ , tc "@I song.mp3" $ Left Nothing -- non-ID3 @I: don't overwrite+ , tc "@I {" $ Left Nothing -- grouping marker: ignored+ , tcId3 ["nörmalise"] $ Right (I (Id3 s "" "" s))+ , tcId3 [s] $ Right (I (Id3 s "" "" s))+ ])+ , testGroup "tagline, errors, junk"+ [ tc "@E some failure" $ Left (Just "some failure")+ , tc "garbage" $ Left Nothing -- no @ prefix+ , tc "@F" $ Left Nothing -- no space after code+ , tc "@" $ Left Nothing+ , tc "" $ Left Nothing+ ]+ ]+ where+ tc line = tc' (show line) line+ tc' tag line expected = testCase tag $ mpgParser line @?= expected+ tcId3 fields = tc' (show fields) (id3 fields)++-- | Build an "@I ID3:" line from fixed-width 30-char fields, as mpg123 emits.+id3 :: [P.ByteString] -> P.ByteString+id3 fields = "@I ID3:" <> mconcat [ P.take 30 (f <> P.replicate 30 ' ') | f <- fields ]+
− test/LexerSpec.hs
@@ -1,65 +0,0 @@-module LexerSpec (tests) where--import Test.Tasty-import Test.Tasty.HUnit--import qualified Data.ByteString.Char8 as P--import Lexer (mpgParser)-import Syntax---- These exercise the helpers doX, 'trim', and 'normalise'.-tests :: TestTree-tests = testGroup "Lexer.mpgParser"- [ testGroup "status (@P)"- [ tc "@P 0" $ Right (S Stopped)- , tc "@P 1" $ Right (S Paused)- , tc "@P 2" $ Right (S Playing)- , tc "@P 3" $ Left Nothing -- end-of-song marker: ignored (no double play)- , tc "@P 9" $ Left Nothing -- unknown code- , tc "@P " $ Left Nothing -- no payload- ]- , testGroup "frame (@F)"- [ tc "@F 123 456 12.34 56.78" $ Right (R (Frame 123 456 12.34 56.78))- , tc "@F 0 0 0.00 -1.00" $ Right (R (Frame 0 0 0.00 0)) -- timeLeft clamped- , tc "@F 1 2 3.00" $ Left Nothing -- too few fields- , tc "@F a b c d" $ Left Nothing -- non-numeric- ]- , testGroup "stream info (@S)"- [ tc "@S 1.0 1 44100 stereo 0 0 2 0 0 0 128 0"- $ Right (I (Info "mpeg 1.0 128kbit/s 44kHz"))- , tc "@S 1.0 1 44100" $ Left Nothing -- too few fields- ]- , testGroup "id3 (@I)" (let s = "n\195\182rmalise" in- [ tcId3 ["Title"]- $ Right (F (Id3 "Title" "" "" "Title"))- , tcId3 ["Title", "Artist"]- $ Right (F (Id3 "Title" "Artist" "" "Artist : Title"))- , tcId3 [" Title", " Artist"]- $ Right (F (Id3 "Title" "Artist" "" "Artist : Title"))- , tcId3 ["Title", "Artist", "Album"]- $ Right (F (Id3 "Title" "Artist" "Album" "Artist : Album : Title"))- , tcId3 ["", "Artist"] $ Left Nothing -- blank title: skipped- , tc "@I song.mp3" $ Left Nothing -- non-ID3 @I: don't overwrite- , tc "@I {" $ Left Nothing -- grouping marker: ignored- , tcId3 ["nörmalise"] $ Right (F (Id3 s "" "" s))- , tcId3 [s] $ Right (F (Id3 s "" "" s))- ])- , testGroup "tagline, errors, junk"- [ tc "@R a tagline" $ Right (T Tag)- , tc "@E some failure" $ Left (Just "some failure")- , tc "garbage" $ Left Nothing -- no @ prefix- , tc "@F" $ Left Nothing -- no space after code- , tc "@" $ Left Nothing- , tc "" $ Left Nothing- ]- ]- where- tc line = tc' (show line) line- tc' tag line expected = testCase tag $ mpgParser line @?= expected- tcId3 fields = tc' (show fields) (id3 fields)---- | Build an "@I ID3:" line from fixed-width 30-char fields, as mpg123 emits.-id3 :: [P.ByteString] -> P.ByteString-id3 fields = "@I ID3:" <> mconcat [ P.take 30 (f <> P.replicate 30 ' ') | f <- fields ]-
test/Main.hs view
@@ -2,20 +2,22 @@ import Test.Tasty -import qualified ConfigSpec-import qualified CoreSpec-import qualified LexerSpec-import qualified StyleSpec-import qualified TreeSpec-import qualified WidthSpec+import BaseSpec qualified+import ConfigSpec qualified+import CoreSpec qualified+import DecoderSpec qualified+import PlaylistSpec qualified+import StyleSpec qualified+import WidthSpec qualified main :: IO () main = defaultMain $ testGroup "hmp3-ng"- [ ConfigSpec.tests+ [ BaseSpec.tests+ , ConfigSpec.tests , CoreSpec.tests- , LexerSpec.tests+ , DecoderSpec.tests , StyleSpec.tests- , TreeSpec.tests+ , PlaylistSpec.tests , WidthSpec.tests ]
+ test/PlaylistSpec.hs view
@@ -0,0 +1,39 @@+module PlaylistSpec (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import Playlist (doOrphans, merge)++tests :: TestTree+tests = testGroup "Playlist"+ [ 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/TreeSpec.hs
@@ -1,38 +0,0 @@-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
@@ -4,7 +4,7 @@ import Test.Tasty.HUnit import Data.ByteString (ByteString)-import qualified Data.ByteString.UTF8 as UTF8+import Data.ByteString.UTF8 qualified as UTF8 import Width (displayWidth, toMaxWidth, toWidth)