hmp3-ng 2.19.1 → 2.20.0
raw patch · 27 files changed
+2299/−2199 lines, 27 files
Files
- Base.hs +0/−64
- Core.hs +0/−557
- Decoder.hs +0/−131
- Elements.hs +0/−149
- Keyboard.hs +0/−35
- Keymap.hs +0/−193
- Playlist.hs +0/−131
- README.md +37/−37
- State.hs +0/−141
- Style.hs +0/−268
- Text.hs +0/−89
- UI.hs +0/−369
- app/Main.hs +5/−6
- hmp3-ng.cabal +4/−3
- src/Base.hs +64/−0
- src/Core.hs +552/−0
- src/Decoder.hs +131/−0
- src/Elements.hs +145/−0
- src/Keyboard.hs +35/−0
- src/Keymap.hs +193/−0
- src/Playlist.hs +129/−0
- src/State.hs +142/−0
- src/Style.hs +269/−0
- src/Text.hs +164/−0
- src/UI.hs +363/−0
- test/ElementsSpec.hs +26/−7
- test/TextSpec.hs +40/−19
− Base.hs
@@ -1,64 +0,0 @@--- Copyright (c) 2020-2026 Galen Huntington--- SPDX-License-Identifier: GPL-2.0-or-later--module Base (module Prelude, module X, module Base) where--import Prelude---- As of now, just including as needed.--- I'm using the list in rebase as an upper bound on what qualifies.--import Control.Concurrent as X-import Control.Exception as X-import Control.Monad as X-import Data.ByteString as X (ByteString)-import Data.Char as X-import Data.Either as X-import Data.Fixed as X-import Data.Foldable as X-import Data.Functor as X hiding (unzip)-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-import Data.Void as X-import Data.Word as X-import System.Exit as X-import System.IO as X (Handle, hClose)-import System.IO.Unsafe as X-import Text.Printf as X-import Text.Read as X (readMaybe)--import System.Clock----- Random utility functions.--discardErrors :: IO () -> IO ()-discardErrors = X.handle @SomeException (\_ -> pure ())--getMonoTime :: IO TimeSpec-getMonoTime = getTime Monotonic--whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()-whenJust = flip $ maybe $ pure ()---- Compatibility: List.!? only added in GHC 9.8-(!?) :: [a] -> Int -> Maybe a-xs !? n = listToMaybe $ drop n xs---- | Zipper structure, representing a list with a cursor.-data Zipper a = Zipper { cur :: !a, back :: ![a], front :: ![a] }--zipEdit :: (a -> a) -> Zipper a -> Zipper a-zipEdit f z = z { cur = f z.cur }--zipUp, zipDown :: Zipper a -> Zipper a-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-
− Core.hs
@@ -1,557 +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------- | Main module. ----module Core (- Options(..),- start, shutdown,- upOne, downOne, pause, nextMode, playNext, playPrev,- forcePause, putMessage, clearMessage, playCursor, playCur,- jumpToPlaying, jump, jumpRel, jumpRandom,- upPage, downPage,- seek, seekStart, adjFolderCol,- blacklist,- setsModal, closeModal, showHist,- search, repeatSearch,- toggleFocus, jumpToNextDir, jumpToPrevDir,- loadConfig,- discardErrors,-) where--import Base--import Decoder-import State-import Style-import Playlist-import Text (matches)-import UI qualified-import Elements qualified as El--import Data.ByteString.Char8 qualified as P-import Data.Sequence qualified as Seq--import Data.Array ((!), Array)-import Data.Proxy-import Data.Tuple (swap)-import Control.Monad.Except-import Control.Monad.State.Strict-import System.Directory (doesFileExist, findExecutable, createDirectoryIfMissing,- getXdgDirectory, XdgDirectory(..))-import System.IO (hPutStrLn, stderr)-import System.Process (runInteractiveProcess, waitForProcess)-import System.Random (randomR, newStdGen)-import System.FilePath qualified as FP ((</>))-import System.Posix.FilePath (takeFileName, (</>))-import System.Posix.Process (exitImmediately)------------------------------------------------------------------------------- | Command-line configuration.-data Options = Options- { paused :: !Bool -- ^ start in a paused state- , configPath :: !(Maybe FilePath) -- ^ override the style.conf location- , playMode :: Maybe Mode -- ^ play mode- , histSize :: Int -- ^ history size- , random :: Bool -- ^ start on random song- }---- | Sets up state, spawns sub-threads, and starts player.-start :: Options -> Playlist -> IO ()-start opts (Playlist folders music) = do-- uiStyle <- UI.start- bootTime <- getMonoTime- mode <- maybe readState pure opts.playMode- gen <- newStdGen- let (current, randomGen) = if mode == Random || opts.random- then randomR (0, length music - 1) gen else (0, gen)-- putMVar hState HState- { music- , folders- , bootTime- , configPath = opts.configPath- , current- , cursor = current- , randomGen- , mode- , uiStyle- , spawns = 0- , clock = Nothing- , info = Nothing- , id3 = Nothing- , modal = Nothing- , playHist = mempty- , searchHist = []- , searchType = SearchType True True- , folderCol = 0.334- , histSize = opts.histSize- , miniFocused = False- , status = Stopped- , minibuffer = []- , uptime = mempty- }-- loadConfig -- TODO this should return config rather than setting it-- traverse_ forkIO- [ mpgLoop- , mpgInput- , refreshLoop- , uptimeLoop- ]-- -- Poll for a second for process to start, then play.- let go :: Int -> IO ()- go 0 = silentlyModifyHS \st -> st { spawns = 1 }- go n = do- ready <- isJust <$> readIORef mpgRef- if ready- then do- playCur- when opts.paused pause -- TODO use LOADPAUSED?- else do- threadDelay 20_000- go (n-1)- go 50------------------------------------------------------------------------------- | Uniform loop and thread handler-runForever :: IO () -> IO ()-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.--- For profiling, make sure to return True for anything:-exitTime :: SomeException -> Bool-exitTime e | is @IOException Proxy e = False -- ignore- | is @ErrorCall Proxy e = False -- ignore- -- "user errors" were caught before, but are no longer a thing- | otherwise = True- where is :: forall e. Exception e => Proxy e -> SomeException -> Bool- is _ = isJust . fromException @e------------------------------------------------------------------------------ | Loop, launching decoder and updating global state.-mpgLoop :: IO ()-mpgLoop = runForever do- empg <- runExceptT do- mppath <- lift (findExecutable mp3Tool) >>=- maybe (throwError $ "Cannot find " ++ mp3Tool ++ " in path") pure- lift (try @SomeException $- runInteractiveProcess mppath ["-R", "--remote-err"] Nothing Nothing- ) >>= flip either pure \ex ->- throwError $ mp3Tool ++ " failed to start; retrying: " ++ show ex- case empg of- Left err -> do- warnA err- -- Hackily count failed initial spawn, for Ready message- silentlyModifyHS \st -> st { spawns = st.spawns `max` 1 }- threadDelay 20_000_000 -- longer wait after these errors- Right handles -> do- ct <- modifyHS $ \st -> let sp = st.spawns + 1 in (st- { status = Stopped- , info = Nothing- , id3 = Nothing- , spawns = sp- }, sp)- when (ct > 1) $ warnA $ mp3Tool ++ " #" ++ show ct ++ ": Ready"- overseeMpg handles- threadDelay 1_000_000 -- let threads spit errors- warnA $ "Restarting " ++ mp3Tool ++ " ..."- threadDelay 4_000_000 -- rate-limit respawns------------------------------------------------------------------------------ | When the editor state has been modified, refresh, then wait--- for it to be modified again.-refreshLoop :: IO ()-refreshLoop = runForever $ takeMVar modified *> UI.refresh------------------------------------------------------------------------------ | The clock ticks once per minute, but check more often in case of drift.-uptimeLoop :: IO ()-uptimeLoop = runForever do- now <- getMonoTime- μs <- modifyHS \st -> let diff = now - st.bootTime in- (st { uptime = El.showDuration False diff }, diff `div` 1000)- threadDelay $ fromIntegral $ let m = 60_000_000 in m - μs `mod` m------------------------------------------------------------------------------ | Handle messages arriving over a pipe from the decoder process. When--- shutdown kills the other end of the pipe, hGetLine will fail.-mpgInput :: IO ()-mpgInput = runForever $ do- line <- P.hGetLine =<< readMVar mpgRead- case mpgParser line of- Right m -> handleMsg m- Left (Just e) -> warnA (mp3Tool ++ ": " ++ e)- _ -> pure ()------------------------------------------------------------------------------ | Close most things. Important to do all the jobs:-shutdown :: Maybe String -> IO ()-shutdown ms = do- UI.end- mpg <- readIORef mpgRef- whenJust mpg \Mpg { mpgPH } -> do- discardErrors writeState- void $ sendMpg' Quit- void $ waitForProcess mpgPH- exitImmediately =<< case ms of- Just s -> hPutStrLn stderr s *> pure (ExitFailure 1)- _ -> pure ExitSuccess----------------------------------------------------------------------------- Process incoming messages from the decoder.--handleMsg :: Msg -> IO ()-handleMsg (S i) = modifyHS_ \st -> st { info = Just i }-handleMsg (I id3) = modifyHS_ \st -> st { id3 = Just id3 }-handleMsg (P t) = do- modifyHS_ \st -> st- { status = t- , clock = case st.clock of -- push stopped clock towards end- Just fr | t == Stopped -> Just $ adjFrame 0.1 fr- c -> c- }- when (t == Stopped) playNext-handleMsg (F f) = do- silentlyModifyHS \st -> st { clock = Just f }- UI.refreshClock----------------------------------------------------------------------------- Basic operations--adjFrame :: Fixed E2 -> Frame -> Frame-adjFrame s fr = Frame { elapsed = fr.elapsed + s', left = fr.left - s' }- where s' = (s `min` fr.left) `max` (- fr.elapsed)--seekStart :: IO ()-seekStart = seek $ fromIntegral $ minBound @Int---- | Seek in relative seconds-seek :: Fixed E2 -> IO ()-seek s = do- mss <- modifyHS \st -> case st.clock of- Just fr -> let fr' = adjFrame s fr- in (st { clock = Just fr' }, Just fr'.elapsed)- Nothing -> (st, Nothing)- whenJust mss $ sendMpg . Jump--adjFolderCol :: Int -> IO ()-adjFolderCol adj = do- (_, sz) <- UI.screenSize- modifyHS_ \st -> st { folderCol =- let fc' = st.folderCol + fromIntegral adj / fromIntegral sz- in (fc' `max` 0) `min` 1 }------------------------------------------------------------------------------ | Generic jump-jumpFn :: (Int -> Int) -> IO ()-jumpFn fn = modifyHS_ \st ->- st { cursor = (fn st.cursor `min` (st.size - 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- jumpFn (+ dir*(1`max`(sz-5)))--upPage, downPage :: IO ()-upPage = page (-1)-downPage = page ( 1)---- | Move cursor to specified index-jump :: Int -> IO ()-jump = jumpFn . const---- | Jump to relative place, 0 to 1.-jumpRel :: Rational -> IO ()-jumpRel r | r < 0 || r >= 1 = pure ()- | True = modifyHS_ $ \st ->- st { cursor = floor $ fromIntegral st.size * r }---- | Experimental feature concept.-blacklist :: IO ()-blacklist = do- st <- getsHS id- appendFile ".hmp3-delete" . (++"\n") . P.unpack $- let fe = st.music ! st.cursor- in (st.folders ! fe.fdir).dname </> fe.fbase------------------------------------------------------------------------------ | Operates on HState and outputs maybe a track to play.-type PlayOp = State HState (Maybe Int)---- | Play the song under the cursor or next if that one is current-playCursor :: IO ()-playCursor = runPlayOp do- HState { current, cursor } <- get- if current == cursor then playNextOp else pure $ Just cursor---- | Play the song under the cursor (from the start)-playCur :: IO ()-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 = runPlayOp do- st <- get- case st.mode of- Random -> playRandomOp- Single -> pure Nothing- _ | st.current > 0- -> pure $ Just $ st.current - 1- Loop -> pure $ Just $ st.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 = runPlayOp playNextOp--playNextOp :: PlayOp-playNextOp = do- st <- get- let next = st.current + 1- case st.mode of- Random -> playRandomOp- Single -> pure Nothing- _ | next < st.size- -> pure $ Just next- Loop -> pure $ Just 0- Once -> pure Nothing---- | Generate a random song-getRandom :: State HState Int-getRandom = do- st <- get- let (new, gen') = randomR (0, st.size - 1) st.randomGen- put $ st { randomGen = gen' }- pure new---- | Random song-playRandomOp :: PlayOp-playRandomOp = Just <$> getRandom---- | Jump to random song-jumpRandom :: Bool -> IO ()-jumpRandom play = runPlayOp do- cursor <- getRandom- modify' \st -> st { cursor }- pure $ if play then Just cursor else Nothing---- | Generic next song selection--- If cursor is on current, drag it along.-runPlayOp :: PlayOp -> IO ()-runPlayOp op = do- now <- getMonoTime- mfile <- modifyHS $ swap . runState do- mnew <- op- forM mnew \new -> do- HState { .. } <- get- let fe = music ! new- f = (folders ! fe.fdir).dname </> fe.fbase- modify' \st -> st- { current = new- , status = Playing- , cursor = if current == cursor then new else cursor- , playHist = Seq.take histSize $ (now, new) <| playHist- , id3 = Nothing- , clock = Nothing- }- pure f- forM_ mfile $ sendMpg . Load------------------------------------------------------------------------------ | Toggle pause on the current song-pause :: IO ()-pause = sendMpg Pause---- | Always pause-forcePause :: IO ()-forcePause = do- st <- getsHS (.status)- when (st == Playing) pause------------------------------------------------------------------------------ | Move cursor to currently playing song-jumpToPlaying :: IO ()-jumpToPlaying = modifyHS_ $ \st -> st { cursor = st.current }---- | Move cursor to first song in next directory (or wrap)-jumpToNextDir, jumpToPrevDir :: IO ()-jumpToNextDir = jumpToDir (\i len -> min (i+1) (len-1))-jumpToPrevDir = jumpToDir (\i _ -> max (i-1) 0)---- | Generic jump to dir-jumpToDir :: (Int -> Int -> Int) -> IO ()-jumpToDir fn = modifyHS_ \st ->- let i = (st.music ! st.cursor).fdir- d = fn i (length st.folders)- in st { cursor = (st.folders ! d).dlo }------------------------------------------------------------------------------ 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 -> ByteString-instance Lookup Dir where extract = takeFileName . (.dname)-instance Lookup File where extract = (.fbase)--setSearchErr :: HState -> ByteString -> HState-setSearchErr st err = st { minibuffer = [plainSeg err] }--search :: SearchType -> ByteString -> IO ()-search typ pat = modifyHS_ \st ->- dispatchSearch (st { searchType = typ }) pat typ--repeatSearch :: Bool -> IO ()-repeatSearch same = modifyHS_ \st -> case st.searchHist of- pat : _ -> dispatchSearch st pat- st.searchType { isForwards = st.searchType.isForwards == same }- _ -> setSearchErr st "No previous search."--dispatchSearch :: HState -> ByteString -> SearchType -> HState-dispatchSearch st pat typ =- either (setSearchErr st) (\i -> st { cursor = i }) case typ of- SearchType True fw ->- genericMatch pat fw st.music st.cursor st.size- SearchType False fw -> do- j <- genericMatch pat fw st.folders (st.music ! st.cursor).fdir- $ length st.folders- pure (st.folders ! j).dlo--genericMatch :: Lookup a => ByteString -> Bool -> Array Int a -> Int -> Int- -> Either ByteString Int-genericMatch pat fw fs cur sz = do- let l = if fw then [cur+1 .. sz-1] ++ [0 .. cur]- else [cur-1, cur-2 .. 0] ++ [sz-1, sz-2 .. cur]- match <- maybe (Left "Invalid ERE search pattern.") Right $ matches pat- case [ i | i <- l, match $ extract (fs ! i) ] of- i : _ -> Right i- _ -> Left "No match found."------------------------------------------------------------------------------ | General modal setting.-setsModal :: (HState -> Maybe Modal) -> IO ()-setsModal f = modifyHS_ $ \st -> st { modal = f st }---- | Close any open modal.-closeModal :: IO ()-closeModal = setsModal $ const Nothing---- | Show history.-showHist :: IO ()-showHist = do- now <- getMonoTime- setsModal \st -> Just $ HistModal [- (El.showDuration True (now - tm), (ix, (st.music ! ix).fbase))- | (tm, ix) <- toList st.playHist ]---- | Focus the minibuffer-toggleFocus :: IO ()-toggleFocus = modifyHS_ $ \st -> st { miniFocused = not st.miniFocused }---- | Toggle the mode flag-nextMode :: IO ()-nextMode = modifyHS_ $ \st -> st { mode = next st.mode } where- next v = if v == maxBound then minBound else succ v----------------------------------------------------------------------------getStatePath :: IO FilePath-getStatePath = getXdgDirectory XdgState "hmp3"---- | Save mode state-writeState :: IO ()-writeState = do- dir <- getStatePath- createDirectoryIfMissing True dir- mode <- getsHS (.mode)- writeFile (dir FP.</> "mode") $ show mode ++ "\n"---- | Read mode state-readState :: IO Mode-readState = do- dir <- getStatePath- let f = dir FP.</> "mode"- b <- doesFileExist f- modeM <- if b- then readMaybe <$!> readFile f- else pure Nothing- pure $ fromMaybe minBound modeM----------------------------------------------------------------------------- Read styles from style.conf-----getConfPath :: IO FilePath-getConfPath = getXdgDirectory XdgConfig $ "hmp3" FP.</> "style.conf"--loadConfig :: IO ()-loadConfig = do- f <- maybe getConfPath pure =<< getsHS (.configPath)- b <- doesFileExist f- if b then do- str' <- readFile f- str <- let (old, new) = ("hmp3_helpscreen", "hmp3_modals") in- case findIndex (old `isPrefixOf`) $ tails str' of- Just ix -> do- warnA $ old ++ " is now " ++ new ++ " in style.conf"- pure $ take ix str' ++ new ++ drop (ix + length old) str'- _ -> pure str'- case readMaybe str of- Nothing -> do- warnA "Parse error in style.conf"- Just rsty -> do- let sty = buildStyle rsty- initcolours sty- modifyHS_ $ \st -> st { uiStyle = sty }- else- pure () -- TODO in some cases show a warning- UI.resetui----------------------------------------------------------------------------- Set the minibuffer--putMessage :: Line -> IO ()-putMessage s = modifyHS_ \st -> st { minibuffer = s }--clearMessage :: IO ()-clearMessage = putMessage []--warnA :: String -> IO ()-warnA x = do- sty <- getsHS (.uiStyle.warnings)- putMessage [Seg sty (P.pack x)]-
− Decoder.hs
@@ -1,131 +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---- Wire protocol for mpg123--module Decoder (- mp3Tool, mpgParser, Cmd(..), cmdToBS,- Msg(..), Id3(..), Status(..), Frame(..),-) where--import Base-import Text (trim, readIntM, showInt, guessEncoding)--import Data.ByteString.Char8 qualified as P---mp3Tool :: IsString a => a-mp3Tool = "mpg123"----------------------------------------------------------------------------- Send commands to mpg123--data Cmd = Load !ByteString | Jump !(Fixed E2) | Pause | Quit--cmdToBS :: Cmd -> ByteString-cmdToBS (Load f) = "L " <> f-cmdToBS (Jump s) = "J " <> (P.pack . show) s <> "s"-cmdToBS Pause = "P" -- (un)pauses-cmdToBS Quit = "Q"----------------------------------------------------------------------------- Receive messages from mpg123--data Msg = I !Id3 | S !ByteString | F !Frame | P !Status- deriving stock (Eq, Show)---- ID3 info-data Id3 = Id3- { title :: !ByteString- , artist :: !ByteString- , album :: !ByteString- , str :: !ByteString- -- , year :: Maybe ByteString- -- , genre :: Maybe ByteString }- } deriving stock (Eq, Show)---- Frame decoding status updates (once per frame).--- Current-time and time-remaining are numbers with two decimal places.-data Frame = Frame { elapsed :: !(Fixed E2), left :: !(Fixed E2) }- deriving stock (Eq, Show)---- Stop/pause status.-data Status = Stopped | Paused | Playing- deriving stock (Eq, Show)--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- _ : _ : f2 : f3 : _ <- pure $ P.split ' ' s- elapsed <- readMaybe $ P.unpack f2- left <- max 0 <$> readMaybe (P.unpack f3)- pure $ F Frame { elapsed, left }---- 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 <- readIntM $ fs !! 2- pure $ S $ mconcat [- "mpeg ", fs !! 0, " ", fs !! 10, "kb/s ", showInt $ 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 $ id3.title -- 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 guessEncoding (trim 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 !?)---- 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-
− Elements.hs
@@ -1,149 +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--module Elements where--import Base-import Decoder (Frame(..))-import Keyboard (charToKey, historyKeys)-import State-import Text-import Paths_hmp3_ng (version)--import Data.ByteString.Char8 qualified as P-import System.Clock-import UI.HSCurses.Curses qualified as Curses---package :: String-package = "hmp3-ng"--fullVersion :: String-fullVersion = package ++ " v" ++ showVersion version---- | Version info-pVersion :: ByteString-pVersion = P.pack fullVersion--commonModalWidth :: Int -> Int-commonModalWidth w = max (min w 3) $ round $ fromIntegral w * (0.8::Float)--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---- | Human-friendly duration, with a flag to include seconds.-showDuration :: Bool -> TimeSpec -> ByteString-showDuration showSecs tm- | ms == 0 && showSecs- = go ""- | hs == 0 = go $ printf "%dm" m- | d == 0 = go $ printf "%dh%02dm" h m- | True = go $ printf "%dd%02dh%02dm" d h m- where- go = P.pack . ss- (ms, s) = sec tm `quotRem` 60- (hs, m) = ms `quotRem` 60- (d, h) = hs `quotRem` 24- ss =- if showSecs then (<> printf (if ms > 0 then "%02ds" else "%ds") s) else id---- | The time used and time left-pTimes :: Int -> Maybe Frame -> ByteString-pTimes w clock- | w - 4 < P.length elapsed = ""- | True =- mconcat $ [" ", elapsed] ++ [gap <> "-" <> left | distance > 0]- where- elapsed = showClock (maybe 0 (.elapsed) clock)- left = maybe "?:??.?" (showClock . (.left)) clock- gap = spaces distance- distance = w - 5 - P.length elapsed - P.length left---- | Progress out of total-progress :: Int -> Maybe Frame -> Int-progress width = maybe 0 \fr ->- let total = curr + toRational fr.left - ε- curr = toRational fr.elapsed- ε = 1 / 200- in ceiling (curr * fromIntegral (width - 1) / total)--data Fit = Fit { wide :: !Bool, padL :: !Int, padR :: !Int, ctake :: !Int }- deriving stock Show---- | Given a width and size of left, center, and right elements, determine--- whether left and right can fit, padding between, and amount of center to show-fitLCR :: Int -> (Int, Int, Int) -> Fit-fitLCR w (lsz, csz, rsz) = if- | gap >= 2 -> let gapl = 1 `max` ((side - lsz) `min` (gap - 1))- in Fit True gapl (gap - gapl) csz- | w-2 >= csz -> Fit False side (sides - side) csz- | w > 1 -> Fit False 1 1 (w-2)- | True -> Fit False w 0 0- where- sides = w - csz- side = sides `div` 2- gap = sides - lsz - rsz--layoutLCR :: Int -> (ByteString, String, ByteString) -> ByteString-layoutLCR w (left, centerS, right) = mconcat [- if fit.wide then left else "",- spaces fit.padL,- u $ take fit.ctake centerS,- spaces fit.padR,- if fit.wide then right else ""- ]- where- fit = fitLCR w (P.length left, length centerS, P.length right)----- Modals---- screen width -> (modal width, list of lines)-type ModalMaker = Int -> (Int, [ByteString])--helpModal :: [KeysHelp] -> ModalMaker-helpModal help swd = (wd, map showLine help) where- wd = commonModalWidth swd- showLine :: ([Char], ByteString) -> ByteString- showLine (cs, ps) = toWidth clen cmds <> 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]--histModal :: HistDisplay -> ModalMaker-histModal [] _ = let s = " No history " in (P.length s, [s])-histModal hist swd = do- let wd = commonModalWidth swd- mtlen = maximum $ map (displayWidth . fst) hist- tlen = min (mtlen + 1) $ wd `div` 3- (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 ])--exitModal :: ModalMaker-exitModal swd = (wd, ["", padl <> "Exit (y)?", ""]) where- wd = commonModalWidth swd `min` 19- padl = P.replicate ((wd - 9) `div` 2) ' '-
− Keyboard.hs
@@ -1,35 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}---- Copyright (c) 2019, 2023-2026 Galen Huntington--- SPDX-License-Identifier: GPL-2.0-or-later--module Keyboard (unkey, charToKey, Key(..), historyKeys) where--import Base--import Data.Map.Strict qualified as M-import Data.Sequence qualified as Seq-import UI.HSCurses.Curses (Key(..), decodeKey)----------------------------------------------------------------------------- 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).--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' .. '\500']]--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
@@ -1,193 +0,0 @@--- Copyright (c) 2004-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------- | Keymap manipulation.------ 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 (keyLoop, keyTable, unkey, charToKey, dropLastUTF8) where--import Base--import Core-import Elements (package)-import Keyboard (unkey, charToKey, Key(..), historyKeys)-import State (getsHS, modifyHS_, KeysHelp, Modal(..), HState(..), SearchType(..), mpgRef, Mpg(..))-import Style (plainSeg)-import Text (dropLastUTF8)-import UI qualified (getKey, resetui)--import Control.Monad.Trans.Maybe-import Data.ByteString.Char8 qualified as P-import Data.ByteString.UTF8 qualified as UTF8-import Data.Map.Strict qualified as M-import System.Process (getPid)-import System.Posix.Signals (signalProcess, sigINT)------------------------------------------------------------------------------ The keymap driver---- | A 'KeyMap' handles the next keystroke and produces the 'KeyMap' to--- use thereafter.-newtype KeyMap = KeyMap (Char -> IO KeyMap)---- | 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 Void-keyLoop = go mainMode where- go (KeyMap f) = UI.getKey >>= \c -> clearMessage *> f c >>= go------------------------------------------------------------------------------ Top-level normal mode--mainMode :: KeyMap-mainMode = KeyMap \c -> getsHS (.modal) >>= \case-- 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)- closeModal $> mainMode-- _ -> if- | c `elem` ['/', '?', '\\', '|'] -> do- toggleFocus- hist <- getsHS (.searchHist)- searchMode c $ Zipper "" hist []- | c >= '1' && c <= '9' ->- jumpRel (fromIntegral (fromEnum c - 48) / 10) $> mainMode- | True -> sequence_ (M.lookup c keyMap) $> mainMode----- Helpers--historyKeyMap :: M.Map Char Int-historyKeyMap = M.fromList $ zip (toList historyKeys) [0..]--askExit :: IO ()-askExit = setsModal $ const $ Just ExitModal--controlC :: IO ()-controlC = do- mpid <- runMaybeT do- mpg <- MaybeT $ readIORef mpgRef- MaybeT $ getPid mpg.mpgPH- maybe askExit (signalProcess sigINT) mpid----------------------------------------------------------------------------- Search mode--searchMode :: Char -> Zipper ByteString -> IO KeyMap-searchMode stype = step where- step z = renderSearch stype z $> KeyMap (`dispatch` z)-- dispatch c z- | c `elem` ['\ESC', '\^C']- = clearMessage *> leave- | c `elem` enter' = commit z- | c `elem` delete' = step $ zipEdit dropLastUTF8 z- | k == KeyUp = step $ zipUp z- | k == KeyDown = step $ zipDown z- | k == KeyDC = histDelete z- | c < ' ' || c > '\255'- = step z -- ignore other special keys- | otherwise = step $ zipEdit (`P.snoc` c) z- where k = charToKey c-- commit (Zipper "" _ _) = clearMessage *> leave- commit (Zipper pat _ _) = do- search (SearchType (stype `elem` ['/', '?']) (stype `elem` ['/', '\\'])) pat- modifyHS_ \st -> st { searchHist = pat : filter (/= pat) st.searchHist }- leave-- 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 (/= z.cur) st.searchHist }- step z'-- leave = toggleFocus $> mainMode--renderSearch :: Char -> Zipper ByteString -> IO ()-renderSearch prefix z = putMessage [plainSeg $ prefix `P.cons` z.cur]--enter', delete' :: [Char]-enter' = ['\n', '\r']-delete' = ['\BS', '\DEL', unkey KeyBackspace]------------------------------------------------------------------------------ The keymap with help descriptions and actions.--keyTable :: [(ByteString, [Char], IO ())]-keyTable =- [ ("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 10 seconds; shift for one minute", [unkey KeyLeft, unkey KeyRight], placeholder)- , ("Toggle pause", [' '], pause)- , ("Play under cursor", ['p'], playCur)- , ("Play from cursor", ['\n'], playCursor)- , ("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)- , ("Select random track", ['r'], jumpRandom False)- , ("Select and play random track", ['R'], jumpRandom True)- , ("Cycle through normal, random, loop, and single modes",- ['m'], nextMode)- , ("Refresh the display", ['\^L'], UI.resetui)- , ("Repeat last regex search", ['n'], repeatSearch True)- , ("Repeat last regex search backwards", ['N'], repeatSearch False)- , ("Mark for deletion in .hmp3-delete", ['D'], blacklist)- , ("Restart song", [unkey KeyBackspace], seekStart)- , ("Toggle the song history", ['H', ';'], showHist)- , ("Search for file matching regex", ['/'], placeholder)- , ("Search backwards for file", ['?'], placeholder)- , ("Search for directory matching regex", ['\\'], placeholder)- , ("Search backwards for directory", ['|'], placeholder)- , ("Change size of folder and file columns", ['[', ']'], placeholder)- , ("Load config file", ['l'], loadConfig)- , ("Quit " <> UTF8.fromString package, ['q'], forcePause *> askExit)- ]- where placeholder = pure () -- handled separately---- | Not shown in help menu (or grouped there).-quietKeys :: [(Char, IO ())]-quietKeys =- [ (unkey KeyLeft, seek (-10))- , (unkey KeyRight, seek 10)- , (unkey KeySLeft, seek (-60))- , (unkey KeySRight, seek 60)- , ('[', adjFolderCol (-1))- , (']', adjFolderCol 1)- , ('\^C', controlC)- ]---- Compiled dispatch table for normal-mode single-key commands.-keyMap :: M.Map Char (IO ())-keyMap = M.fromList $ [ (c, a) | (_, cs, a) <- keyTable, c <- cs ] ++ quietKeys--keysHelp :: [KeysHelp]-keysHelp = [ (keys, desc) | (desc, keys, _) <- keyTable ]--toggleHelp :: IO ()-toggleHelp = setsModal \st ->- if isNothing st.modal then Just $ HelpModal keysHelp else Nothing-
− Playlist.hs
@@ -1,131 +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--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
@@ -1,14 +1,45 @@ [](https://hackage.haskell.org/package/hmp3-ng)  -## hmp3-ng+`hmp3-ng` (installed as `hmp3`) is an mp3 music player that runs in+a text terminal with a curses interface. -The original `hmp3` music player, written in Haskell, dates to 2005,-and has a curses interface for use in a text terminal. However,-it has become abandonware: the last update was in June 2008, and-it no longer builds with today’s Haskell and standard libraries.-This repository is an effort to resurrect this software.+## Installation +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.++The build depends on the package `hscurses`, which in turn requires+curses dev files. In Ubuntu/Debian, for example, these can be obtained+by installing `libncurses-dev`.++## Use++The `hmp3` executable is invoked with a list of mp3 files or+directories of mp3 files.++```+$ hmp3 ~/Music ~/Downloads/La-La.mp3+```++Once running, `hmp3` is controlled by fairly intuitive key commands.+`h` shows a help menu, and `q` quits. `hmp3 --help` prints a simple+help message with command line options.++A color scheme can be specified by writing out a `Config { .. }`+value in `~/.config/hmp3/style.conf` (or wherever your XDG config is).+See `Style.hs` for the definition. The `l` command hot-reloads this+configuration.++## History++The original `hmp3` music player, written in Haskell, dates to 2005.+However, it has become abandonware: the last update was in June 2008,+and it no longer builds with today’s Haskell and standard libraries.+This repository was a fork in 2019 to resurrect this software.+The code has since been heavily rewritten.+ The original Darcs repo has vanished from the Internet. However, I have a copy I checked out in 2008 (to hack on!) with all the patches through version 1.5.1 (the latest is 1.5.2.1), and Hackage has tarballs@@ -53,37 +84,6 @@ * Work on other features and changes, and documentation, is ongoing. This is still a work in progress. Let me know if there are problems.---## Installation--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.--The build depends on the package `hscurses`, which in turn requires-curses dev files. In Ubuntu/Debian, for example, these can be obtained-by installing `libncurses-dev`.---## Use--The `hmp3` executable is invoked with a list of mp3 files or-directories of mp3 files.--```-$ hmp3 ~/Music ~/Downloads/La-La.mp3-```--Once running, `hmp3` is controlled by fairly intuitive key commands.-`h` shows a help menu, and `q` quits. `hmp3 -h` prints a simple help-message with command line options.--A color scheme can be specified by writing out a `Config { .. }`-value in `~/.config/hmp3/style.conf` (or wherever your XDG config is).-See `Style.hs` for the definition. The `l` command hot-reloads this-configuration.- ## Original authorship
− State.hs
@@ -1,141 +0,0 @@--- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019-2026 Galen Huntington--- SPDX-License-Identifier: GPL-2.0-or-later------- | The top level application state, and operations on that value.----module State where--import Base--import Decoder (Status, Frame, Id3, Cmd, cmdToBS, mp3Tool)-import Playlist (FileArray, DirArray)-import Style (Line, Segment(Seg), UIStyle(warnings))--import Data.ByteString (hPut)-import GHC.Records-import System.Clock (TimeSpec(..))-import System.IO (hFlush)-import System.Process (ProcessHandle, waitForProcess)-import System.Random (StdGen)----- | Player state-data HState = HState- -- These never change- { music :: !FileArray- , folders :: !DirArray- , bootTime :: !TimeSpec- , configPath :: !(Maybe FilePath) -- style.conf override (CLI)- , histSize :: !Int- -- These can- , current :: !Int -- currently playing mp3- , cursor :: !Int -- mp3 under the cursor- , clock :: !(Maybe Frame) -- current clock value- , randomGen :: !StdGen -- random seed- , spawns :: !Integer -- count of decoder spawns- , id3 :: !(Maybe Id3) -- maybe mp3 id3 info- , info :: !(Maybe ByteString) -- mp3 info- , status :: !Status- , minibuffer :: !Line -- contents of minibuffer- , modal :: !(Maybe Modal) -- modal visible- , miniFocused :: !Bool -- is the mini buffer focused?- , folderCol :: !Float -- portion of width for folders- , mode :: !Mode- , uptime :: !ByteString- , searchType :: !SearchType- , searchHist :: ![ByteString]- , playHist :: !(Seq (TimeSpec, Int))- , uiStyle :: !UIStyle- }--instance HasField "size" HState Int where getField hs = length hs.music--data Mode = Once | Loop | Random | Single- deriving stock (Eq, Bounded, Enum, Show, Read)--data SearchType = SearchType { isFiles :: !Bool, isForwards :: !Bool }---- Each is (timestamp-string, (song-index, song-name)).-type HistDisplay = [(ByteString, (Int, ByteString))]---- (list-of-keys, description)-type KeysHelp = ([Char], ByteString)--data Modal = HelpModal ![KeysHelp] | ExitModal | HistModal !HistDisplay---- | A global variable holding the state.-hState :: MVar HState-hState = unsafePerformIO newEmptyMVar-{-# NOINLINE hState #-}---- | The refresh thread waits on this-modified :: MVar ()-modified = unsafePerformIO newEmptyMVar-{-# NOINLINE modified #-}---- | Queues a refresh.-setModified :: IO ()-setModified = void $ tryPutMVar modified ()----------------------------------------------------------------------------- The decoder.---- | Decoder read handle (mpg123 stderr).-mpgRead :: MVar Handle-mpgRead = unsafePerformIO newEmptyMVar-{-# NOINLINE mpgRead #-}--data Mpg = Mpg { mpgPH :: !ProcessHandle, writeHM :: !(MVar Handle) }---- | Decoder process and write handles.-mpgRef :: IORef (Maybe Mpg)-mpgRef = unsafePerformIO $ newIORef Nothing-{-# NOINLINE mpgRef #-}--overseeMpg :: (Handle, Handle, Handle, ProcessHandle) -> IO ()-overseeMpg (writeH, _, errH, mpgPH) = do- putMVar mpgRead errH- writeHM <- newMVar writeH- writeIORef mpgRef $ Just Mpg { mpgPH, writeHM }- void $ try @SomeException $ waitForProcess mpgPH- writeIORef mpgRef Nothing- void $ takeMVar mpgRead---- | Returns whether succeeded.-sendMpg' :: Cmd -> IO Bool-sendMpg' c = do- mpg <- readIORef mpgRef- case mpg of- Just Mpg { writeHM } -> do- h <- readMVar writeHM- fmap isRight $ try @SomeException $- hPut h (cmdToBS c) *> hPut h "\n" *> hFlush h- _ -> pure False---- | Runs above and posts warning on failure.-sendMpg :: Cmd -> IO ()-sendMpg c = do- ok <- sendMpg' c- when (not ok) $ modifyHS_ \st -> st { minibuffer =- [Seg st.uiStyle.warnings (mp3Tool <> " process not running")] }----------------------------------------------------------------------------- State accessor functions.---- | Access a component of the state with a projection function-getsHS :: (HState -> a) -> IO a-getsHS f = f <$> readMVar hState---- | Modify the state with a pure function and no refresh-silentlyModifyHS :: (HState -> HState) -> IO ()-silentlyModifyHS f = modifyMVar_ hState (pure . f)--modifyHS_ :: (HState -> HState) -> IO ()-modifyHS_ f = silentlyModifyHS f <* setModified---- | Modify the state returning a value-modifyHS :: (HState -> (HState, a)) -> IO a-modifyHS f = modifyMVar hState (pure . f) <* setModified-
− Style.hs
@@ -1,268 +0,0 @@--- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019-2022, 2026 Galen Huntington--- SPDX-License-Identifier: GPL-2.0-or-later---- | Color manipulation--module Style where--import Base-import UI.HSCurses.Curses qualified as Curses-import Data.Map qualified as M------------------------------------------------------------------------------ | User-configurable colours--- Each component of this structure corresponds to a fg\/bg colour pair--- for an item in the ui-data UIStyle = UIStyle {- window :: !Style -- default window colour- , modals :: !Style -- help screen- , titlebar :: !Style -- titlebar of window- , selected :: !Style -- currently playing track- , cursors :: !Style -- the scrolling cursor line- , combined :: !Style -- the style to use when the cursor is on the current track- , warnings :: !Style -- style for warnings- , blockcursor :: !Style -- style for the block cursor when typing text- , progress :: !Style -- style for the progress bar- }------------------------------------------------------------------------------ | 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- deriving stock (Eq,Ord)---- | A styled UTF-8 ByteString segment.-data Segment = Seg !Style {-# UNPACK #-} !ByteString---- | A line of segments.-type Line = [Segment]----------------------------------------------------------------------------- | 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 $ 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----------------------------------------------------------------------------- | Set some colours, perform an action, and then reset the colours-withStyle :: Style -> IO () -> IO ()-withStyle sty fn = uiAttr sty >>= setAttribute >> fn >> reset-{-# INLINE withStyle #-}---- | manipulate the current attributes of the standard screen--- Only set attr if it's different to the current one?-setAttribute :: (Curses.Attr, Curses.Pair) -> IO ()-setAttribute = uncurry Curses.attrSet---- | Reset the screen to normal values-reset :: IO ()-reset = setAttribute (Curses.attr0, Curses.Pair 0)---- | And turn on the colours-initcolours :: UIStyle -> IO ()-initcolours sty = do- let ls = [sty.modals, sty.warnings, sty.window,- sty.selected, sty.titlebar, sty.progress,- sty.blockcursor, sty.cursors, sty.combined ]- Style fg bg = sty.progress -- bonus style- pairs <- initUiColors (ls ++ [Style bg bg, Style fg fg])- writeIORef pairMap pairs- -- set the background- uiAttr sty.window >>= \(_,p) -> Curses.bkgrndSet nullA p----------------------------------------------------------------------------- | Set up the ui attributes, given a ui style record------ Returns an association list of pairs for foreground and bg colors,--- associated with the terminal color pair that has been defined for--- those colors.----initUiColors :: [Style] -> IO PairMap-initUiColors stys = do - ls <- sequence [ uncurry fn m | m <- zip stys [1..] ]- pure (M.fromList ls)- where- fn :: Style -> Int -> IO (Style, (Curses.Attr,Curses.Pair))- fn sty p = do- let (CColor (a,fgc),CColor (b,bgc)) = style2curses sty- discardErrors $ Curses.initPair (Curses.Pair p) fgc bgc- pure (sty, (a `Curses.attrPlus` b, Curses.Pair p))----------------------------------------------------------------------------- | Getting from nice abstract colours to ncurses-settable values---- 20% of allocss occur here! But there's only 3 or 4 colours :/--- Every call to uiAttr-uiAttr :: Style -> IO (Curses.Attr, Curses.Pair)-uiAttr sty = do- m <- readIORef pairMap- pure $ lookupPair m sty---- | Given a curses color pair, find the Curses.Pair (i.e. the pair--- curses thinks these colors map to) from the state-lookupPair :: PairMap -> Style -> (Curses.Attr, Curses.Pair)-lookupPair m s =- fromMaybe (Curses.attr0, Curses.Pair 0) (M.lookup s m)---- | Keep a map of nice style defs to underlying curses pairs, created at init time-type PairMap = M.Map Style (Curses.Attr, Curses.Pair)---- | map of Curses.Color pairs to ncurses terminal Pair settings-pairMap :: IORef PairMap-pairMap = unsafePerformIO $ newIORef M.empty-{-# NOINLINE pairMap #-}----------------------------------------------------------------------------- Basic (ncurses) colours.--defaultColor :: Curses.Color-defaultColor = fromJust $ Curses.color "default"---- Combine attribute with another attribute-setBoldA, setReverseA :: Curses.Attr -> Curses.Attr-setBoldA = flip Curses.setBold True-setReverseA = flip Curses.setReverse True---- | Some attribute constants-boldA, nullA, reverseA :: Curses.Attr-nullA = Curses.attr0-boldA = setBoldA nullA-reverseA = setReverseA nullA----------------------------------------------------------------------------newtype CColor = CColor (Curses.Attr, Curses.Color)---- | Map an abstract 'Style' to its ncurses foreground/background pair.-style2curses :: Style -> (CColor, CColor)-style2curses (Style fg bg) = (fgCursCol fg, bgCursCol bg)---- | 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 = \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 = \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)--plainSeg :: ByteString -> Segment-plainSeg = Seg defaultSty----------------------------------------------------------------------------- Support for runtime configuration--- We choose a simple strategy, read/showable record types, with strings--- to represent colors------ The fields must map to UIStyle------ It is this data type that is stored in 'show' format in style.conf----data Config = Config {- hmp3_window :: (String,String)- , hmp3_modals :: (String,String)- , hmp3_titlebar :: (String,String)- , hmp3_selected :: (String,String)- , hmp3_cursors :: (String,String)- , hmp3_combined :: (String,String)- , hmp3_warnings :: (String,String)- , hmp3_blockcursor :: (String,String)- , hmp3_progress :: (String,String)- } deriving stock (Show,Read)---- | Read style.conf, and construct a UIStyle from it, to insert into-buildStyle :: Config -> UIStyle-buildStyle bs = UIStyle {- window = f bs.hmp3_window- , modals = f bs.hmp3_modals- , titlebar = f bs.hmp3_titlebar- , selected = f bs.hmp3_selected- , cursors = f bs.hmp3_cursors- , combined = f bs.hmp3_combined- , warnings = f bs.hmp3_warnings- , blockcursor = f bs.hmp3_blockcursor- , progress = f bs.hmp3_progress- }- where - f (x,y) = Style (g x) (g y)- g x = fromMaybe Default $ stringToColor x---- Built-in styles--defaultStyle :: UIStyle-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"- }--monoStyle :: UIStyle-monoStyle = UIStyle- { 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"- }-
− Text.hs
@@ -1,89 +0,0 @@--- Copyright (c) 2019-2026 Galen Huntington--- SPDX-License-Identifier: GPL-2.0-or-later---- For various reasons, ByteString is the lingua franca for this app.--- This module provides basic text string functions.--module Text (- u, matches,- trim, spaces, guessEncoding, dropLastUTF8,- readIntM, showInt,- displayWidth, toMaxWidth, toWidth-) where--import Base--import Data.ByteString.Char8 qualified as P-import Data.ByteString.UTF8 qualified as UTF8-import Text.Regex.Posix (match, makeRegexOptsM, compIgnoreCase, compExtended)--import Foreign.C.Types (CWchar(..), CInt(..))----- | Write u-strings like it's Python 2.-u :: String -> ByteString-u = UTF8.fromString---- | Strip leading and trailing whitespace.-trim :: ByteString -> ByteString-trim = P.dropWhileEnd isSpace . P.dropSpace--spaces :: Int -> ByteString-spaces = flip P.replicate ' '---- | Swappable API for searching-matches :: ByteString -> Maybe (ByteString -> Bool)-matches s = match <$> makeRegexOptsM (compIgnoreCase + compExtended) 0 s--readIntM :: ByteString -> Maybe Int-readIntM = fmap fst . P.readInt--showInt :: Int -> ByteString-showInt = P.pack . show---- | If seeming ISO-8859-1, convert to UTF-8.-guessEncoding :: ByteString -> ByteString-guessEncoding bs =- if UTF8.replacement_char `elem` UTF8.toString bs- then UTF8.fromString $ P.unpack bs- else bs---- | Drop last UTF-8 codepoint.-dropLastUTF8 :: ByteString -> ByteString-dropLastUTF8 = P.dropEnd 1 . P.dropWhileEnd isCB- where isCB b = b >= '\128' && b < '\192'----- Width-aware operations on UTF-8 'ByteString's, using libc 'wcwidth'.--- A UTF-8 runtime locale is presumed; counts may differ otherwise.---- | 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-
− UI.hs
@@ -1,369 +0,0 @@--- 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. --module UI (- runDraw,- -- * Construction, destruction- start, end, screenSize, refresh, refreshClock, resetui,- -- * Input- getKey,- -- * Tool- u,- ) where--import Base-import Elements as El-import Style-import Playlist (File(fdir, fbase), Dir(dname))-import State-import Decoder-import Text (u, displayWidth, toMaxWidth, toWidth, spaces, showInt)-import UI.HSCurses.Curses qualified as Curses-import Keyboard (unkey)--import Data.Array ((!), bounds, Array)-import Data.Array.Base (unsafeAt)-import System.Posix.FilePath (takeFileName)-import System.IO (stderr, hFlush)-import System.Posix.Signals (installHandler, Handler(..))--import Foreign.C.String-import Foreign.C.Types-import Foreign.C.Error (Errno(..), getErrno)--import Data.ByteString.Char8 qualified as P-import Data.ByteString.Unsafe qualified as P---newtype Draw = Draw (IO ())- deriving newtype (Semigroup, Monoid)--drawLock :: MVar ()-drawLock = unsafePerformIO $ newMVar ()-{-# NOINLINE drawLock #-}--runDraw :: Draw -> IO ()-runDraw (Draw io) = withMVar drawLock $ const io------------------------------------------------------------------------------ | Initialize the UI-start :: IO UIStyle-start = do- Curses.initCurses-- case Curses.cursesSigWinch of- Just wch -> void $ installHandler wch (Catch resetui) Nothing- _ -> pure () -- handled elsewhere-- colorify <- Curses.hasColors- let sty = if colorify then defaultStyle else monoStyle-- initcolours sty- Curses.keypad Curses.stdScr True -- grab the keyboard- runDraw nocursor-- pure sty---- | Reset-resetui :: IO ()-resetui = runDraw (resizeui <> nocursor) *> refresh---- | And force invisible-nocursor :: Draw-nocursor = Draw $ discardErrors $ void $ Curses.cursSet Curses.CursorInvisible---- | Clean up and go home.-end :: IO ()-end = do- takeMVar drawLock -- we keep so no one tries to draw- setXtermTitle ["xterm"] -- XXX I don't see this title after exit?- Curses.endWin---- | Find the current screen height and width.-screenSize :: IO (Int, Int)-screenSize = Curses.scrSize---- | Rewrite of Curses.getCh to avoid looping on terminal crash--- | (also no unget support since I don't need it)-getCh :: IO Curses.Key-getCh = do- threadWaitRead 0- v <- Curses.getch- case v of- -1 -> do- Errno e <- getErrno- putStrLn $ "Error " ++ show e ++ "; terminal has gone away? Hard-exiting now."- exitFailure- k -> pure $ Curses.decodeKey k---- | Read a key. UIs need to define a method for getting events.--- We only need to refresh if we don't have no SIGWINCH support.-getKey :: IO Char-getKey = do- k <- getCh- if k == Curses.KeyResize - then do- when (isNothing Curses.cursesSigWinch) do- runDraw $ redraw <> resizeui- getKey- else pure $ unkey k---- | Resize the window--- From "Writing Programs with NCURSES", by Eric S. Raymond and Zeyd M. Ben-Halim-resizeui :: Draw-resizeui = Draw do- Curses.endWin- Curses.resetParams- do- -- not sure I need all these...- Curses.nl True- _ <- Curses.leaveOk True- Curses.noDelay Curses.stdScr False- Curses.cBreak True- -- Curses.meta stdScr True -- not in module- -- not sure about intrFlush, raw - set in hscurses- Curses.refresh- void Curses.scrSize--refresh :: IO ()-refresh = runDraw $ redraw <> Draw Curses.refresh--refreshClock :: IO ()-refreshClock = runDraw $ redrawJustClock <> Draw Curses.refresh----------------------------------------------------------------------------data DrawData = DD { drawWidth :: !Int, drawState :: !HState }------------------------------------------------------------------------------ | Info about the current track-pPlaying :: DrawData -> Line-pPlaying dd = pure $ plainSeg $ " " <> mconcat line where- x = dd.drawWidth- a = pId3 dd- b = fromMaybe "" dd.drawState.info -- mp3 info- 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 a- showId3 = x > 59- right = if showId3 then [" ", b] else []---- | Id3 info-pId3 :: DrawData -> ByteString-pId3 DD{drawState=st} = maybe (st.music ! st.current).fbase (.str) st.id3------------------------------------------------------------------------------ | Show progress bar.-progressBar :: DrawData -> Line-progressBar (DD w st) = [- plainSeg " ", Seg (Style fg fg) (spaces x), Seg sty (spaces (w'-x)) ]- where- w' = w - 4- x = El.progress w' st.clock- sty@(Style fg _) = st.uiStyle.progress---- | Two lines showing clock.-clockLines :: DrawData -> [Line]-clockLines dd@(DD w st) = [progressBar dd, [plainSeg (El.pTimes w st.clock)]]------------------------------------------------------------------------------ | Play state-pState :: DrawData -> String-pState dd = case dd.drawState.status of- Stopped -> "◼"- Paused -> "⏸"- Playing -> "▶"---- | Play mode-pMode :: DrawData -> String-pMode dd = take 4 $ map toLower $ show dd.drawState.mode------------------------------------------------------------------------------ | "x/n dirs y/m files" cursor position read-out.-playInfo :: DrawData -> ByteString-playInfo DD{drawState=st} = mconcat- [ spaces (P.length numd - P.length curd)- , curd, "/", numd, " dirs"- , spaces (1 + P.length numf - P.length curf)- , curf, "/", numf, " files"- ]- where- curf = showInt $ st.cursor + 1- numf = showInt $ st.size- curd = showInt $ (st.music ! st.cursor).fdir + 1- numd = showInt $ length $ st.folders---- | The top title bar: cursor position + play indicator + uptime + version.-playTitle :: DrawData -> Line-playTitle dd@DD{drawWidth=w, drawState=st} =- [Seg st.uiStyle.titlebar $ El.layoutLCR w (left, centerS, right)]- where- left = " " <> playInfo dd- centerS = pState dd ++ ' ' : pMode dd -- always 6 chars- right = st.uptime <> " " <> El.pVersion <> " "---- | The scrolling playlist (visible tracks).-playList :: Int -> DrawData -> [Line]-playList buflen _ | buflen <= 0 = [] -- extra defense besides laziness-playList buflen DD{ drawWidth=w, drawState=st } =- list ++ replicate (buflen - length list) []-- where- -- number of screens down, and then offset- (screens, select) = st.cursor `quotRem` buflen -- keep cursor in screen- playing = st.current - screens * buflen -- invisible if out of bounds-- -- visible slice of the playlist- visible = slice off (off + buflen - 1) st.music- where off = screens * buflen-- visible' :: [(Maybe Int, ByteString)]- visible' = loop (-1) visible where- loop _ [] = []- loop n (v:vs) =- let r = if v.fdir > n then Just v.fdir else Nothing- in (r, toMaxWidth (w - indent - 1) v.fbase) : loop v.fdir vs-- list = [ drawIt . color $ n | n <- zip visible' [0..] ]-- indent = round $ st.folderCol * fromIntegral (w - 1) :: Int-- (sty1, sty2, sty3) = (cs.selected, cs.cursors, cs.combined)- where cs = st.uiStyle-- 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 (w - indent - 1 - displayWidth s)])-- drawIt :: (Maybe Int, (Style, [ByteString])) -> Line- drawIt (Nothing, (sty, v)) =- map (Seg sty) $ spaces (1 + indent) : v- drawIt (Just i, (sty, v)) = Seg sty' d- : Seg sty' (spaces (indent + 1 - displayWidth d))- : map (Seg sty) v- where- sty' = if sty == sty2 || sty == sty3 then sty2 else sty1- d = toMaxWidth (indent - 1) $ takeFileName (st.folders ! i).dname----------------------------------------------------------------------------- | Write out only the clock lines.-redrawJustClock :: Draw-redrawJustClock = Draw $ discardErrors do- st <- getsHS id- (h, w) <- screenSize- drawFullLines (h-1) 1 $ clockLines $ DD w st----------------------------------------------------------------------------- | General modal renderer.-renderModal :: HState -> (Int, Int) -> ModalMaker -> IO ()-renderModal st (h, w) mkr = do- let (mw, modal') = mkr w- hoffset = max 0 $ (w - mw) `div` 2- vislines = (h - 5) `min` length modal'- voffset = ((h - vislines) `div` 2) `max` 4- for_ (zip [voffset..] $ take vislines modal') \ (y, t) -> do- Curses.wMove Curses.stdScr y hoffset- drawSegment $ Seg st.uiStyle.modals (toWidth mw t)---- | Choose modal to render based on state.-renderModals :: HState -> (Int, Int) -> IO ()-renderModals st sz =- whenJust st.modal $ renderModal st sz . \case- HelpModal h -> El.helpModal h- HistModal h -> El.histModal h- ExitModal -> El.exitModal----------------------------------------------------------------------------- | Draw the screen--- Errors can maybe be thrown if screen gets resized mid-render.-redraw :: Draw-redraw = Draw $ discardErrors do- st <- getsHS id- sz@(h, w) <- screenSize- setXterm st- drawFullLines (h-1) 0 $ let dd = DD w st in- pPlaying dd : clockLines dd ++ playTitle dd : playList (h-5) dd- renderModals st sz- -- minibuffer- Curses.wMove Curses.stdScr (h-1) 0- drawLine st.minibuffer- when st.miniFocused do -- a fake cursor- drawSegment $ Seg st.uiStyle.blockcursor " "- fillLine---- | Render whole lines without going below limit.-drawFullLines :: Int -> Int -> [Line] -> IO ()-drawFullLines limit y ls =- for_ (zip [y .. limit-1] ls) \ (y', t) -> do- Curses.wMove Curses.stdScr y' 0- drawLine t *> fillLine----------------------------------------------------------------------------- | Draw a coloured (or not) string to the screen-drawLine :: Line -> IO ()-drawLine = traverse_ drawSegment---- | Write a single styled UTF-8 segment. Safe because C only reads the bytes.-drawSegment :: Segment -> IO ()-drawSegment (Seg sty bs) = withStyle sty $ void $- P.unsafeUseAsCStringLen bs \(cstr, len) ->- waddnstr Curses.stdScr cstr (fromIntegral len)------------------------------------------------------------------------------ | Fill to end of line spaces--- (Curses throws error if already at end.)-fillLine :: IO ()-fillLine = discardErrors Curses.clrToEol---- | Take a slice of an array efficiently-slice :: Int -> Int -> Array Int e -> [e]-slice i j arr = - let (a, b) = bounds arr- in [unsafeAt arr n | n <- [max a i .. min b j]]------------------------------------------------------------------------------ | magics for setting xterm titles using ansi escape sequences-setXtermTitle :: [ByteString] -> IO ()-setXtermTitle strs = do- traverse_ (P.hPut stderr) (before : strs ++ [after])- hFlush stderr - where- before = "\ESC]0;"- after = "\007"------------------------------------------------------------------------------ set xterm title. Don't need to do this on each refresh...-setXterm :: HState -> IO ()-setXterm st = setXtermTitle case st.status of- Playing -> case st.id3 of- Just id3 -> id3.artist :- if P.null id3.title then [] else [": ", id3.title]- _ -> [(st.music ! st.current).fbase]- Paused -> ["paused"]- Stopped -> ["stopped"]---foreign import ccall safe- waddnstr :: Curses.Window -> CString -> CInt -> IO CInt-
app/Main.hs view
@@ -11,12 +11,11 @@ import Elements (fullVersion) import Keymap (keyLoop) import Playlist (buildPlaylist, isEmpty)+import Text (encodeFS) import System.Posix.Signals (installHandler, Handler(Ignore, Default, Catch), sigTERM, sigPIPE, sigINT, sigHUP , sigALRM, sigABRT) -import Data.ByteString.UTF8 qualified as UTF8- import Options.Applicative -- ---------------------------------------------------------------------@@ -45,7 +44,7 @@ -- | Command-line parsing. -- | The options together with the file/directory arguments.-invocation :: Parser (Options, [ByteString])+invocation :: Parser (Options, [String]) invocation = (,) <$> opts <*> files where opts = Options@@ -61,9 +60,9 @@ long "history" <> short 'h' <> metavar "NUM" <> value 61 <> help "Size of play history, up to 61 selectable" <> showDefault) <*> switch (long "random" <> help "Start on a random song")- files = some $ argument (UTF8.fromString <$> str) (metavar "FILE|DIR...")+ files = some $ argument str (metavar "FILE|DIR...") -parserInfo :: ParserInfo (Options, [ByteString])+parserInfo :: ParserInfo (Options, [String]) parserInfo = info (invocation <**> versionOpt <**> helper) $ fullDesc <> header fullVersion@@ -85,7 +84,7 @@ main :: IO () main = do (opts, args) <- customExecParser (prefs showHelpOnEmpty) parserInfo- list <- buildPlaylist args+ list <- buildPlaylist =<< traverse encodeFS args when (isEmpty list) $ errorWithoutStackTrace "Error: No music files found." initSignals
hmp3-ng.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: hmp3-ng-version: 2.19.1-synopsis: A 2019 fork of an ncurses mp3 player written in Haskell+version: 2.20.0+synopsis: A TUI 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@@ -26,6 +26,7 @@ default-language: GHC2021 default-extensions: BlockArguments+ DuplicateRecordFields MultiWayIf NoFieldSelectors OverloadedRecordDot@@ -42,7 +43,7 @@ library import: opts- hs-source-dirs: ./+ hs-source-dirs: src exposed-modules: Base Core
+ src/Base.hs view
@@ -0,0 +1,64 @@+-- Copyright (c) 2020-2026 Galen Huntington+-- SPDX-License-Identifier: GPL-2.0-or-later++module Base (module Prelude, module X, module Base) where++import Prelude++-- As of now, just including as needed.+-- I'm using the list in rebase as an upper bound on what qualifies.++import Control.Concurrent as X+import Control.Exception as X+import Control.Monad as X+import Data.ByteString as X (ByteString)+import Data.Char as X+import Data.Either as X+import Data.Fixed as X+import Data.Foldable as X+import Data.Functor as X hiding (unzip)+import Data.IORef as X+import Data.List as X hiding ((!?))+import Data.Maybe as X+import Data.List.NonEmpty as X (NonEmpty(..))+import Data.Sequence as X (Seq, (<|), (|>))+import Data.String as X+import Data.Traversable as X+import Data.Version as X+import Data.Void as X+import Data.Word as X+import System.Exit as X+import System.IO as X (Handle, hClose)+import System.IO.Unsafe as X+import Text.Read as X (readMaybe)++import System.Clock+++-- Random utility functions.++discardErrors :: IO () -> IO ()+discardErrors = X.handle @SomeException (\_ -> pure ())++getMonoTime :: IO TimeSpec+getMonoTime = getTime Monotonic++whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenJust = flip $ maybe $ pure ()++-- Compatibility: List.!? only added in GHC 9.8+(!?) :: [a] -> Int -> Maybe a+xs !? n = listToMaybe $ drop n xs++-- | Zipper structure, representing a list with a cursor.+data Zipper a = Zipper { cur :: !a, back :: ![a], front :: ![a] }++zipEdit :: (a -> a) -> Zipper a -> Zipper a+zipEdit f z = z { cur = f z.cur }++zipUp, zipDown :: Zipper a -> Zipper a+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+
+ src/Core.hs view
@@ -0,0 +1,552 @@+-- 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++--+-- | Main module.+--+module Core (+ Options(..),+ start, shutdown,+ upOne, downOne, pause, nextMode, playNext, playPrev,+ forcePause, putMessage, clearMessage, playCursor, playCur,+ jumpToPlaying, jump, jumpRel, jumpRandom,+ upPage, downPage,+ seek, seekStart, adjFolderCol,+ blacklist,+ setsModal, closeModal, showHist,+ search, repeatSearch,+ toggleFocus, jumpToNextDir, jumpToPrevDir,+ loadConfig,+ discardErrors,+) where++import Base++import Decoder+import State+import Style+import Playlist+import Text (matches, SText)+import UI qualified+import Elements qualified as El++import Data.ByteString.Char8 qualified as P+import Data.Sequence qualified as Seq++import Data.Array ((!), Array)+import Data.Proxy+import Data.Tuple (swap)+import Control.Monad.Except+import Control.Monad.State.Strict+import System.Directory (doesFileExist, findExecutable, createDirectoryIfMissing,+ getXdgDirectory, XdgDirectory(..))+import System.IO (hPutStrLn, stderr)+import System.Process (runInteractiveProcess, waitForProcess)+import System.Random (randomR, newStdGen)+import System.FilePath qualified as FP ((</>))+import System.Posix.FilePath ((</>))+import System.Posix.Process (exitImmediately)+++------------------------------------------------------------------------++-- | Command-line configuration.+data Options = Options+ { paused :: !Bool -- ^ start in a paused state+ , configPath :: !(Maybe FilePath) -- ^ override the style.conf location+ , playMode :: Maybe Mode -- ^ play mode+ , histSize :: Int -- ^ history size+ , random :: Bool -- ^ start on random song+ }++-- | Sets up state, spawns sub-threads, and starts player.+start :: Options -> Playlist -> IO ()+start opts (Playlist folders music) = do++ uiStyle <- UI.start+ bootTime <- getMonoTime+ mode <- maybe readState pure opts.playMode+ gen <- newStdGen+ let (current, randomGen) = if mode == Random || opts.random+ then randomR (0, length music - 1) gen else (0, gen)++ putMVar hState HState+ { music+ , folders+ , bootTime+ , configPath = opts.configPath+ , current+ , cursor = current+ , randomGen+ , mode+ , uiStyle+ , spawns = 0+ , clock = Nothing+ , info = Nothing+ , id3 = Nothing+ , modal = Nothing+ , playHist = mempty+ , searchHist = []+ , searchType = SearchType True True+ , folderCol = 0.334+ , histSize = opts.histSize+ , miniFocused = False+ , status = Stopped+ , minibuffer = []+ , uptime = mempty+ }++ loadConfig -- TODO this should return config rather than setting it++ traverse_ forkIO+ [ mpgLoop+ , mpgInput+ , refreshLoop+ , uptimeLoop+ ]++ -- Poll for a second for process to start, then play.+ let go :: Int -> IO ()+ go 0 = silentlyModifyHS \st -> st { spawns = 1 }+ go n = do+ ready <- isJust <$> readIORef mpgRef+ if ready+ then do+ playCur+ when opts.paused pause -- TODO use LOADPAUSED?+ else do+ threadDelay 20_000+ go (n-1)+ go 50+++------------------------------------------------------------------------++-- | Uniform loop and thread handler+runForever :: IO () -> IO ()+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.+-- For profiling, make sure to return True for anything:+exitTime :: SomeException -> Bool+exitTime e | is @IOException Proxy e = False -- ignore+ | is @ErrorCall Proxy e = False -- ignore+ -- "user errors" were caught before, but are no longer a thing+ | otherwise = True+ where is :: forall e. Exception e => Proxy e -> SomeException -> Bool+ is _ = isJust . fromException @e++------------------------------------------------------------------------++-- | Loop, launching decoder and updating global state.+mpgLoop :: IO ()+mpgLoop = runForever do+ empg <- runExceptT do+ mppath <- lift (findExecutable mp3Tool) >>=+ maybe (throwError $ "Cannot find " ++ mp3Tool ++ " in path") pure+ lift (try @SomeException $+ runInteractiveProcess mppath ["-R", "--remote-err"] Nothing Nothing+ ) >>= flip either pure \ex ->+ throwError $ mp3Tool ++ " failed to start; retrying: " ++ show ex+ case empg of+ Left err -> do+ warnA err+ -- Hackily count failed initial spawn, for Ready message+ silentlyModifyHS \st -> st { spawns = st.spawns `max` 1 }+ threadDelay 20_000_000 -- longer wait after these errors+ Right handles -> do+ ct <- modifyHS $ \st -> let sp = st.spawns + 1 in (st+ { status = Stopped+ , info = Nothing+ , id3 = Nothing+ , spawns = sp+ }, sp)+ when (ct > 1) $ warnA $ mp3Tool ++ " #" ++ show ct ++ ": Ready"+ overseeMpg handles+ threadDelay 1_000_000 -- let threads spit errors+ warnA $ "Restarting " ++ mp3Tool ++ " ..."+ threadDelay 4_000_000 -- rate-limit respawns++------------------------------------------------------------------------++-- | When the editor state has been modified, refresh, then wait+-- for it to be modified again.+refreshLoop :: IO ()+refreshLoop = runForever $ takeMVar modified *> UI.refresh++------------------------------------------------------------------------++-- | The clock ticks once per minute, but check more often in case of drift.+uptimeLoop :: IO ()+uptimeLoop = runForever do+ now <- getMonoTime+ μs <- modifyHS \st -> let diff = now - st.bootTime in+ (st { uptime = El.showDuration False diff }, diff `div` 1000)+ threadDelay $ fromIntegral $ let m = 60_000_000 in m - μs `mod` m++------------------------------------------------------------------------++-- | Handle messages arriving over a pipe from the decoder process. When+-- shutdown kills the other end of the pipe, hGetLine will fail.+mpgInput :: IO ()+mpgInput = runForever $ do+ line <- P.hGetLine =<< readMVar mpgRead+ case mpgParser line of+ Right m -> handleMsg m+ Left (Just e) -> warnA (mp3Tool ++ ": " ++ e)+ _ -> pure ()++------------------------------------------------------------------------++-- | Close most things. Important to do all the jobs:+shutdown :: Maybe String -> IO ()+shutdown ms = do+ UI.end+ mpg <- readIORef mpgRef+ whenJust mpg \Mpg { mpgPH } -> do+ discardErrors writeState+ void $ sendMpg' Quit+ void $ waitForProcess mpgPH+ exitImmediately =<< case ms of+ Just s -> hPutStrLn stderr s *> pure (ExitFailure 1)+ _ -> pure ExitSuccess++------------------------------------------------------------------------+-- Process incoming messages from the decoder.++handleMsg :: Msg -> IO ()+handleMsg (S i) = modifyHS_ \st -> st { info = Just i }+handleMsg (I id3) = modifyHS_ \st -> st { id3 = Just id3 }+handleMsg (P t) = do+ modifyHS_ \st -> st+ { status = t+ , clock = case st.clock of -- push stopped clock towards end+ Just fr | t == Stopped -> Just $ adjFrame 0.1 fr+ c -> c+ }+ when (t == Stopped) playNext+handleMsg (F f) = do+ silentlyModifyHS \st -> st { clock = Just f }+ UI.refreshClock++------------------------------------------------------------------------+-- Basic operations++adjFrame :: Fixed E2 -> Frame -> Frame+adjFrame s fr = Frame { elapsed = fr.elapsed + s', left = fr.left - s' }+ where s' = (s `min` fr.left) `max` (- fr.elapsed)++seekStart :: IO ()+seekStart = seek $ fromIntegral $ minBound @Int++-- | Seek in relative seconds+seek :: Fixed E2 -> IO ()+seek s = do+ mss <- modifyHS \st -> case st.clock of+ Just fr -> let fr' = adjFrame s fr+ in (st { clock = Just fr' }, Just fr'.elapsed)+ Nothing -> (st, Nothing)+ whenJust mss $ sendMpg . Jump++adjFolderCol :: Int -> IO ()+adjFolderCol adj = do+ (_, sz) <- UI.screenSize+ modifyHS_ \st -> st { folderCol =+ let fc' = st.folderCol + fromIntegral adj / fromIntegral sz+ in (fc' `max` 0) `min` 1 }++------------------------------------------------------------------------++-- | Generic jump+jumpFn :: (Int -> Int) -> IO ()+jumpFn fn = modifyHS_ \st ->+ st { cursor = (fn st.cursor `min` (st.size - 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+ jumpFn (+ dir*(1`max`(sz-5)))++upPage, downPage :: IO ()+upPage = page (-1)+downPage = page ( 1)++-- | Move cursor to specified index+jump :: Int -> IO ()+jump = jumpFn . const++-- | Jump to relative place, 0 to 1.+jumpRel :: Rational -> IO ()+jumpRel r | r < 0 || r >= 1 = pure ()+ | True = modifyHS_ $ \st ->+ st { cursor = floor $ fromIntegral st.size * r }++-- | Experimental feature concept.+blacklist :: IO ()+blacklist = do+ st <- getsHS id+ appendFile ".hmp3-delete" . (++"\n") . P.unpack $+ let fe = st.music ! st.cursor+ in (st.folders ! fe.dir).path </> fe.base++------------------------------------------------------------------------++-- | Operates on HState and outputs maybe a track to play.+type PlayOp = State HState (Maybe Int)++-- | Play the song under the cursor or next if that one is current+playCursor :: IO ()+playCursor = runPlayOp do+ HState { current, cursor } <- get+ if current == cursor then playNextOp else pure $ Just cursor++-- | Play the song under the cursor (from the start)+playCur :: IO ()+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 = runPlayOp do+ st <- get+ case st.mode of+ Random -> playRandomOp+ Single -> pure Nothing+ _ | st.current > 0+ -> pure $ Just $ st.current - 1+ Loop -> pure $ Just $ st.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 = runPlayOp playNextOp++playNextOp :: PlayOp+playNextOp = do+ st <- get+ let next = st.current + 1+ case st.mode of+ Random -> playRandomOp+ Single -> pure Nothing+ _ | next < st.size+ -> pure $ Just next+ Loop -> pure $ Just 0+ Once -> pure Nothing++-- | Generate a random song+getRandom :: State HState Int+getRandom = do+ st <- get+ let (new, gen') = randomR (0, st.size - 1) st.randomGen+ put $ st { randomGen = gen' }+ pure new++-- | Random song+playRandomOp :: PlayOp+playRandomOp = Just <$> getRandom++-- | Jump to random song+jumpRandom :: Bool -> IO ()+jumpRandom play = runPlayOp do+ cursor <- getRandom+ modify' \st -> st { cursor }+ pure $ if play then Just cursor else Nothing++-- | Generic next song selection+-- If cursor is on current, drag it along.+runPlayOp :: PlayOp -> IO ()+runPlayOp op = do+ now <- getMonoTime+ mfile <- modifyHS $ swap . runState do+ mnew <- op+ forM mnew \new -> do+ HState { .. } <- get+ let fe = music ! new+ f = (folders ! fe.dir).path </> fe.base+ modify' \st -> st+ { current = new+ , status = Playing+ , cursor = if current == cursor then new else cursor+ , playHist = Seq.take histSize $ (now, new) <| playHist+ , id3 = Nothing+ , clock = Nothing+ }+ pure f+ forM_ mfile $ sendMpg . Load++------------------------------------------------------------------------++-- | Toggle pause on the current song+pause :: IO ()+pause = sendMpg Pause++-- | Always pause+forcePause :: IO ()+forcePause = do+ st <- getsHS (.status)+ when (st == Playing) pause++------------------------------------------------------------------------++-- | Move cursor to currently playing song+jumpToPlaying :: IO ()+jumpToPlaying = modifyHS_ $ \st -> st { cursor = st.current }++-- | Move cursor to first song in next directory (or wrap)+jumpToNextDir, jumpToPrevDir :: IO ()+jumpToNextDir = jumpToDir (\i len -> min (i+1) (len-1))+jumpToPrevDir = jumpToDir (\i _ -> max (i-1) 0)++-- | Generic jump to dir+jumpToDir :: (Int -> Int -> Int) -> IO ()+jumpToDir fn = modifyHS_ \st ->+ let i = (st.music ! st.cursor).dir+ d = fn i (length st.folders)+ in st { cursor = (st.folders ! d).start }++------------------------------------------------------------------------++setSearchErr :: HState -> SText -> HState+setSearchErr st err = st { minibuffer = [plainSeg err] }++search :: SearchType -> SText -> IO ()+search typ pat = modifyHS_ \st ->+ dispatchSearch (st { searchType = typ }) pat typ++repeatSearch :: Bool -> IO ()+repeatSearch same = modifyHS_ \st -> case st.searchHist of+ pat : _ -> dispatchSearch st pat+ st.searchType { isForwards = st.searchType.isForwards == same }+ _ -> setSearchErr st "No previous search."++dispatchSearch :: HState -> SText -> SearchType -> HState+dispatchSearch st pat typ =+ either (setSearchErr st) (\i -> st { cursor = i }) case typ of+ SearchType True fw ->+ genericMatch pat fw st.music st.cursor st.size+ SearchType False fw -> do+ j <- genericMatch pat fw st.folders (st.music ! st.cursor).dir+ $ length st.folders+ pure (st.folders ! j).start++genericMatch :: HasText a+ => SText -> Bool -> Array Int a -> Int -> Int+ -> Either SText Int+genericMatch pat fw fs cur sz = do+ let l = if fw then [cur+1 .. sz-1] ++ [0 .. cur]+ else [cur-1, cur-2 .. 0] ++ [sz-1, sz-2 .. cur]+ match <- maybe (Left "Invalid ERE search pattern.") Right $ matches pat+ case [ i | i <- l, match (fs ! i).text ] of+ i : _ -> Right i+ _ -> Left "No match found."++------------------------------------------------------------------------++-- | General modal setting.+setsModal :: (HState -> Maybe Modal) -> IO ()+setsModal f = modifyHS_ $ \st -> st { modal = f st }++-- | Close any open modal.+closeModal :: IO ()+closeModal = setsModal $ const Nothing++-- | Show history.+showHist :: IO ()+showHist = do+ now <- getMonoTime+ setsModal \st -> Just $ HistModal [+ (El.showDuration True (now - tm), (ix, (st.music ! ix).text))+ | (tm, ix) <- toList st.playHist ]++-- | Focus the minibuffer+toggleFocus :: IO ()+toggleFocus = modifyHS_ $ \st -> st { miniFocused = not st.miniFocused }++-- | Toggle the mode flag+nextMode :: IO ()+nextMode = modifyHS_ $ \st -> st { mode = next st.mode } where+ next v = if v == maxBound then minBound else succ v++------------------------------------------------------------------------++getStatePath :: IO FilePath+getStatePath = getXdgDirectory XdgState "hmp3"++-- | Save mode state+writeState :: IO ()+writeState = do+ dir <- getStatePath+ createDirectoryIfMissing True dir+ mode <- getsHS (.mode)+ writeFile (dir FP.</> "mode") $ show mode ++ "\n"++-- | Read mode state+readState :: IO Mode+readState = do+ dir <- getStatePath+ let f = dir FP.</> "mode"+ b <- doesFileExist f+ modeM <- if b+ then readMaybe <$!> readFile f+ else pure Nothing+ pure $ fromMaybe minBound modeM++------------------------------------------------------------------------+-- Read styles from style.conf+--++getConfPath :: IO FilePath+getConfPath = getXdgDirectory XdgConfig $ "hmp3" FP.</> "style.conf"++loadConfig :: IO ()+loadConfig = do+ f <- maybe getConfPath pure =<< getsHS (.configPath)+ b <- doesFileExist f+ if b then do+ str' <- readFile f+ str <- let (old, new) = ("hmp3_helpscreen", "hmp3_modals") in+ case findIndex (old `isPrefixOf`) $ tails str' of+ Just ix -> do+ warnA $ old ++ " is now " ++ new ++ " in style.conf"+ pure $ take ix str' ++ new ++ drop (ix + length old) str'+ _ -> pure str'+ case readMaybe str of+ Nothing -> do+ warnA "Parse error in style.conf"+ Just rsty -> do+ let sty = buildStyle rsty+ initcolours sty+ modifyHS_ $ \st -> st { uiStyle = sty }+ else+ pure () -- TODO in some cases show a warning+ UI.resetui++------------------------------------------------------------------------+-- Set the minibuffer++putMessage :: Line -> IO ()+putMessage s = modifyHS_ \st -> st { minibuffer = s }++clearMessage :: IO ()+clearMessage = putMessage []++warnA :: String -> IO ()+warnA x = do+ sty <- getsHS (.uiStyle.warnings)+ putMessage [Seg sty (fromString x)]+
+ src/Decoder.hs view
@@ -0,0 +1,131 @@+-- 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 (+ mp3Tool, mpgParser, Cmd(..), cmdToBS,+ Msg(..), Id3(..), Status(..), Frame(..),+) where++import Base+import Text++import Data.ByteString.Char8 qualified as P+++mp3Tool :: IsString a => a+mp3Tool = "mpg123"++------------------------------------------------------------------------+-- Send commands to mpg123++data Cmd = Load !ByteString | Jump !(Fixed E2) | Pause | Quit++cmdToBS :: Cmd -> ByteString+cmdToBS (Load f) = "L " <> f+cmdToBS (Jump s) = "J " <> (P.pack . show) s <> "s"+cmdToBS Pause = "P" -- (un)pauses+cmdToBS Quit = "Q"++------------------------------------------------------------------------+-- Receive messages from mpg123++data Msg = I !Id3 | S !SText | F !Frame | P !Status+ deriving stock (Eq, Show)++-- ID3 info+data Id3 = Id3+ { title :: !SText+ , artist :: !SText+ , album :: !SText+ , str :: !SText+ -- , year :: Maybe ByteString+ -- , genre :: Maybe ByteString }+ } deriving stock (Eq, Show)++-- Frame decoding status updates (once per frame).+-- Current-time and time-remaining are numbers with two decimal places.+data Frame = Frame { elapsed :: !(Fixed E2), left :: !(Fixed E2) }+ deriving stock (Eq, Show)++-- Stop/pause status.+data Status = Stopped | Paused | Playing+ deriving stock (Eq, Show)++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+ _ : _ : f2 : f3 : _ <- pure $ P.split ' ' s+ elapsed <- readMaybe $ P.unpack f2+ left <- max 0 <$> readMaybe (P.unpack f3)+ pure $ F Frame { elapsed, left }++-- 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 = map fromBS $ P.split ' ' s+ guard $ length fs >= 11+ hz <- readIntM $ fs !! 2+ pure $ S $ mconcat [+ "mpeg ", fs !! 0, " ", fs !! 10, "kb/s ", showInt $ 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 $ notNull id3.title -- 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 guessEncoding (trim a) : cut xs+ toId ls = Id3 (arg 0) (arg 1) (arg 2) $ mconcat $ intersperse " : "+ $ filter notNull [arg 1, arg 2, arg 0]+ where arg = fromMaybe "" . (ls !?)++-- 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+
+ src/Elements.hs view
@@ -0,0 +1,145 @@+-- 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++module Elements where++import Base+import Decoder (Frame(..))+import Keyboard (charToKey, historyKeys)+import State+import Text+import Paths_hmp3_ng (version)++import Data.List.NonEmpty qualified as NE+import System.Clock+import UI.HSCurses.Curses qualified as Curses+++package :: String+package = "hmp3-ng"++fullVersion :: String+fullVersion = package ++ " v" ++ showVersion version++-- | Version info+pVersion :: SText+pVersion = fromString fullVersion++commonModalWidth :: Int -> Int+commonModalWidth w = max (min w 3) $ round $ fromIntegral w * (0.8::Float)++showClock :: Fixed E2 -> SText+showClock t =+ let m, si, sd :: Int+ (m, s) = t `divMod'` 60+ si = floor s+ sd = floor (s*10) `mod` 10+ in mconcat [showInt m, ":", show02d si, ".", showInt sd]++-- | Human-friendly duration, with a flag to include seconds.+showDuration :: Bool -> TimeSpec -> SText+showDuration showSecs tm =+ render $ dropWhile ((==0) . fst) (init parts) `NE.prependList` pure (last parts)+ where+ render ((tv, tu) :| l) =+ mconcat $ showInt tv : tu : foldMap (\ (v, u) -> [show02d v, u]) l+ parts = [(d, "d"), (h, "h"), (m, "m")] ++ [ (s, "s") | showSecs ]+ (ms, s) = fromIntegral (sec tm) `quotRem` 60+ (hs, m) = ms `quotRem` 60+ (d, h) = hs `quotRem` 24++-- | The time used and time left+pTimes :: Int -> Maybe Frame -> SText+pTimes w clock+ | w - 4 < width elapsed = ""+ | True =+ mconcat $ [" ", elapsed] ++ [gap <> "-" <> left | distance > 0]+ where+ elapsed = showClock (maybe 0 (.elapsed) clock)+ left = maybe "?:??.?" (showClock . (.left)) clock+ gap = spaces distance+ distance = w - 5 - width elapsed - width left++-- | Progress out of total+progress :: Int -> Maybe Frame -> Int+progress w = maybe 0 \fr ->+ let total = curr + toRational fr.left - ε+ curr = toRational fr.elapsed+ ε = 1 / 200+ in ceiling (curr * fromIntegral (w - 1) / total)++data Fit = Fit { wide :: !Bool, padL :: !Int, padR :: !Int, ctake :: !Int }+ deriving stock Show++-- | Given a width and size of left, center, and right elements, determine+-- whether left and right can fit, padding between, and amount of center to show+fitLCR :: Int -> (Int, Int, Int) -> Fit+fitLCR w (lsz, csz, rsz) = if+ | gap >= 2 -> let gapl = 1 `max` ((side - lsz) `min` (gap - 1))+ in Fit True gapl (gap - gapl) csz+ | w-2 >= csz -> Fit False side (sides - side) csz+ | w > 1 -> Fit False 1 1 (w-2)+ | True -> Fit False w 0 0+ where+ sides = w - csz+ side = sides `div` 2+ gap = sides - lsz - rsz++layoutLCR :: Int -> (SText, String, SText) -> SText+layoutLCR w (left, centerS, right) = mconcat [+ if fit.wide then left else "",+ spaces fit.padL,+ fromString $ take fit.ctake centerS,+ spaces fit.padR,+ if fit.wide then right else ""+ ]+ where+ fit = fitLCR w (width left, length centerS, width right)+++-- Modals++-- screen width -> (modal width, list of lines)+type ModalMaker = Int -> (Int, [SText])++helpModal :: [KeysHelp] -> ModalMaker+helpModal help swd = (wd, map showLine help) where+ wd = commonModalWidth swd+ showLine :: ([Char], SText) -> SText+ showLine (cs, ps) = toWidth clen cmds <> ps where+ clen = max 4 $ round $ fromIntegral wd * (0.2::Float)+ cmds = mconcat $ intersperse " " $ "" : 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"+ _ -> fromChar c++histModal :: HistDisplay -> ModalMaker+histModal [] _ = let s = " No history " in (width s, [s])+histModal hist swd = do+ let wd = commonModalWidth swd+ mtlen = maximum $ map (width . fst) hist+ tlen = min (mtlen + 1) $ wd `div` 3+ (wd, [+ let tstr = toMaxWidth tlen $ spaces (tlen - width time) <> time+ in mconcat [" ", fromChar c, " ", tstr, " ", song]+ | (c, (time, (_, song))) <- zip (toList historyKeys ++ repeat ' ') hist ])++exitModal :: ModalMaker+exitModal swd = (wd, ["", padl <> "Exit (y)?", ""]) where+ wd = commonModalWidth swd `min` 19+ padl = spaces ((wd - 9) `div` 2)+
+ src/Keyboard.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- Copyright (c) 2019, 2023-2026 Galen Huntington+-- SPDX-License-Identifier: GPL-2.0-or-later++module Keyboard (unkey, charToKey, Key(..), historyKeys) where++import Base++import Data.Map.Strict qualified as M+import Data.Sequence qualified as Seq+import UI.HSCurses.Curses (Key(..), decodeKey)++------------------------------------------------------------------------+-- 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).++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' .. '\500']]++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']+
+ src/Keymap.hs view
@@ -0,0 +1,193 @@+-- Copyright (c) 2004-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++-- | Keymap manipulation.+--+-- 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 (keyLoop, keyTable, unkey, charToKey, dropLastUTF8) where++import Base++import Core+import Elements (package)+import Keyboard (unkey, charToKey, Key(..), historyKeys)+import State (getsHS, modifyHS_, KeysHelp, Modal(..), HState(..), SearchType(..), mpgRef, Mpg(..))+import Style (plainSeg)+import Text (SText, dropLastUTF8, fromBS, toBS)+import UI qualified (getKey, resetui)++import Control.Monad.Trans.Maybe+import Data.ByteString.Char8 qualified as P+import Data.Map.Strict qualified as M+import System.Process (getPid)+import System.Posix.Signals (signalProcess, sigINT)+++------------------------------------------------------------------------+-- The keymap driver++-- | A 'KeyMap' handles the next keystroke and produces the 'KeyMap' to+-- use thereafter.+newtype KeyMap = KeyMap (Char -> IO KeyMap)++-- | 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 Void+keyLoop = go mainMode where+ go (KeyMap f) = UI.getKey >>= \c -> clearMessage *> f c >>= go+++------------------------------------------------------------------------+-- Top-level normal mode++mainMode :: KeyMap+mainMode = KeyMap \c -> getsHS (.modal) >>= \case++ 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)+ closeModal $> mainMode++ _ -> if+ | c `elem` ['/', '?', '\\', '|'] -> do+ toggleFocus+ -- Search text can be transitorily invalid so we drop to ByteString+ hist <- map toBS <$> getsHS (.searchHist)+ searchMode c $ Zipper "" hist []+ | c >= '1' && c <= '9' ->+ jumpRel (fromIntegral (fromEnum c - 48) / 10) $> mainMode+ | True -> sequence_ (M.lookup c keyMap) $> mainMode+++-- Helpers++historyKeyMap :: M.Map Char Int+historyKeyMap = M.fromList $ zip (toList historyKeys) [0..]++askExit :: IO ()+askExit = setsModal $ const $ Just ExitModal++controlC :: IO ()+controlC = do+ mpid <- runMaybeT do+ mpg <- MaybeT $ readIORef mpgRef+ MaybeT $ getPid mpg.mpgPH+ maybe askExit (signalProcess sigINT) mpid++------------------------------------------------------------------------+-- Search mode++searchMode :: Char -> Zipper ByteString -> IO KeyMap+searchMode stype = step where+ step z = renderSearch stype z $> KeyMap (`dispatch` z)++ dispatch c z+ | c `elem` ['\ESC', '\^C']+ = clearMessage *> leave+ | c `elem` enter' = commit z+ | c `elem` delete' = step $ zipEdit dropLastUTF8 z+ | k == KeyUp = step $ zipUp z+ | k == KeyDown = step $ zipDown z+ | k == KeyDC = histDelete z+ | c < ' ' || c > '\255'+ = step z -- ignore other special keys+ | otherwise = step $ zipEdit (`P.snoc` c) z+ where k = charToKey c++ commit (Zipper "" _ _) = clearMessage *> leave+ commit (Zipper raw _ _) = do+ let pat = fromBS raw+ search (SearchType (stype `elem` ['/', '?']) (stype `elem` ['/', '\\'])) pat+ modifyHS_ \st -> st { searchHist = pat : filter (/= pat) st.searchHist }+ leave++ 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 (/= fromBS z.cur) st.searchHist }+ step z'++ leave = toggleFocus $> mainMode++renderSearch :: Char -> Zipper ByteString -> IO ()+renderSearch prefix z = putMessage [plainSeg $ fromBS $ prefix `P.cons` z.cur]++enter', delete' :: [Char]+enter' = ['\n', '\r']+delete' = ['\BS', '\DEL', unkey KeyBackspace]+++------------------------------------------------------------------------+-- The keymap with help descriptions and actions.++keyTable :: [(SText, [Char], IO ())]+keyTable =+ [ ("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 10 seconds; shift for one minute", [unkey KeyLeft, unkey KeyRight], placeholder)+ , ("Toggle pause", [' '], pause)+ , ("Play under cursor", ['p'], playCur)+ , ("Play from cursor", ['\n'], playCursor)+ , ("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)+ , ("Select random track", ['r'], jumpRandom False)+ , ("Select and play random track", ['R'], jumpRandom True)+ , ("Cycle through normal, random, loop, and single modes",+ ['m'], nextMode)+ , ("Refresh the display", ['\^L'], UI.resetui)+ , ("Repeat last regex search", ['n'], repeatSearch True)+ , ("Repeat last regex search backwards", ['N'], repeatSearch False)+ , ("Mark for deletion in .hmp3-delete", ['D'], blacklist)+ , ("Restart song", [unkey KeyBackspace], seekStart)+ , ("Toggle the song history", ['H', ';'], showHist)+ , ("Search for file matching regex", ['/'], placeholder)+ , ("Search backwards for file", ['?'], placeholder)+ , ("Search for directory matching regex", ['\\'], placeholder)+ , ("Search backwards for directory", ['|'], placeholder)+ , ("Change size of folder and file columns", ['[', ']'], placeholder)+ , ("Load config file", ['l'], loadConfig)+ , ("Quit " <> fromString package, ['q'], forcePause *> askExit)+ ]+ where placeholder = pure () -- handled separately++-- | Not shown in help menu (or grouped there).+quietKeys :: [(Char, IO ())]+quietKeys =+ [ (unkey KeyLeft, seek (-10))+ , (unkey KeyRight, seek 10)+ , (unkey KeySLeft, seek (-60))+ , (unkey KeySRight, seek 60)+ , ('[', adjFolderCol (-1))+ , (']', adjFolderCol 1)+ , ('\^C', controlC)+ ]++-- Compiled dispatch table for normal-mode single-key commands.+keyMap :: M.Map Char (IO ())+keyMap = M.fromList $ [ (c, a) | (_, cs, a) <- keyTable, c <- cs ] ++ quietKeys++keysHelp :: [KeysHelp]+keysHelp = [ (keys, desc) | (desc, keys, _) <- keyTable ]++toggleHelp :: IO ()+toggleHelp = setsModal \st ->+ if isNothing st.modal then Just $ HelpModal keysHelp else Nothing+
+ src/Playlist.hs view
@@ -0,0 +1,129 @@+-- 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 Text (fromBS, isLineSafe, SText)++import Data.Array+import Data.ByteString.Char8 qualified as P+import Data.Map.Strict qualified as M+import GHC.Records (HasField)+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++type HasText a = HasField "text" a SText++data Dir = Dir+ { path :: !RawFilePath -- ^ directory name+ , start :: !Int -- ^ index of first entry in FileArray+ , text :: !SText -- ^ displayed text+ }++data File = File+ { base :: !RawFilePath -- ^ basename of file+ , dir :: !Int -- ^ index of Dir entry+ , text :: !SText -- ^ displayed text+ }++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 $ filter isLineSafe 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 =+ let fn = P.copy (takeFileName f)+ in File fn i (fromBS $ dropExtension fn)++------------------------------------------------------------------------++-- | 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 isLineSafe . 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+ path = dropTrailingPathSeparator d+ dir = Dir { path, start = n, text = fromBS (takeFileName path) }+ 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)+
+ src/State.hs view
@@ -0,0 +1,142 @@+-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- Copyright (c) 2019-2026 Galen Huntington+-- SPDX-License-Identifier: GPL-2.0-or-later++--+-- | The top level application state, and operations on that value.+--+module State where++import Base++import Decoder (Status, Frame, Id3, Cmd, cmdToBS, mp3Tool)+import Playlist (FileArray, DirArray)+import Style (Line, Segment(Seg), UIStyle(warnings))+import Text (SText)++import Data.ByteString (hPut)+import GHC.Records (HasField(..))+import System.Clock (TimeSpec(..))+import System.IO (hFlush)+import System.Process (ProcessHandle, waitForProcess)+import System.Random (StdGen)+++-- | Player state+data HState = HState+ -- These never change+ { music :: !FileArray+ , folders :: !DirArray+ , bootTime :: !TimeSpec+ , configPath :: !(Maybe FilePath) -- style.conf override (CLI)+ , histSize :: !Int+ -- These can+ , current :: !Int -- currently playing mp3+ , cursor :: !Int -- mp3 under the cursor+ , clock :: !(Maybe Frame) -- current clock value+ , randomGen :: !StdGen -- random seed+ , spawns :: !Integer -- count of decoder spawns+ , id3 :: !(Maybe Id3) -- maybe mp3 id3 info+ , info :: !(Maybe SText) -- mp3 info+ , status :: !Status+ , minibuffer :: !Line -- contents of minibuffer+ , modal :: !(Maybe Modal) -- modal visible+ , miniFocused :: !Bool -- is the mini buffer focused?+ , folderCol :: !Float -- portion of width for folders+ , mode :: !Mode+ , uptime :: !SText+ , searchType :: !SearchType+ , searchHist :: ![SText]+ , playHist :: !(Seq (TimeSpec, Int))+ , uiStyle :: !UIStyle+ }++instance HasField "size" HState Int where getField hs = length hs.music++data Mode = Once | Loop | Random | Single+ deriving stock (Eq, Bounded, Enum, Show, Read)++data SearchType = SearchType { isFiles :: !Bool, isForwards :: !Bool }++-- Each is (timestamp-string, (song-index, song-name)).+type HistDisplay = [(SText, (Int, SText))]++-- (list-of-keys, description)+type KeysHelp = ([Char], SText)++data Modal = HelpModal ![KeysHelp] | ExitModal | HistModal !HistDisplay++-- | A global variable holding the state.+hState :: MVar HState+hState = unsafePerformIO newEmptyMVar+{-# NOINLINE hState #-}++-- | The refresh thread waits on this+modified :: MVar ()+modified = unsafePerformIO newEmptyMVar+{-# NOINLINE modified #-}++-- | Queues a refresh.+setModified :: IO ()+setModified = void $ tryPutMVar modified ()++------------------------------------------------------------------------+-- The decoder.++-- | Decoder read handle (mpg123 stderr).+mpgRead :: MVar Handle+mpgRead = unsafePerformIO newEmptyMVar+{-# NOINLINE mpgRead #-}++data Mpg = Mpg { mpgPH :: !ProcessHandle, writeHM :: !(MVar Handle) }++-- | Decoder process and write handles.+mpgRef :: IORef (Maybe Mpg)+mpgRef = unsafePerformIO $ newIORef Nothing+{-# NOINLINE mpgRef #-}++overseeMpg :: (Handle, Handle, Handle, ProcessHandle) -> IO ()+overseeMpg (writeH, _, errH, mpgPH) = do+ putMVar mpgRead errH+ writeHM <- newMVar writeH+ writeIORef mpgRef $ Just Mpg { mpgPH, writeHM }+ void $ try @SomeException $ waitForProcess mpgPH+ writeIORef mpgRef Nothing+ void $ takeMVar mpgRead++-- | Returns whether succeeded.+sendMpg' :: Cmd -> IO Bool+sendMpg' c = do+ mpg <- readIORef mpgRef+ case mpg of+ Just Mpg { writeHM } -> do+ h <- readMVar writeHM+ fmap isRight $ try @SomeException $+ hPut h (cmdToBS c) *> hPut h "\n" *> hFlush h+ _ -> pure False++-- | Runs above and posts warning on failure.+sendMpg :: Cmd -> IO ()+sendMpg c = do+ ok <- sendMpg' c+ when (not ok) $ modifyHS_ \st -> st { minibuffer =+ [Seg st.uiStyle.warnings (mp3Tool <> " process not running")] }++------------------------------------------------------------------------+-- State accessor functions.++-- | Access a component of the state with a projection function+getsHS :: (HState -> a) -> IO a+getsHS f = f <$> readMVar hState++-- | Modify the state with a pure function and no refresh+silentlyModifyHS :: (HState -> HState) -> IO ()+silentlyModifyHS f = modifyMVar_ hState (pure . f)++modifyHS_ :: (HState -> HState) -> IO ()+modifyHS_ f = silentlyModifyHS f <* setModified++-- | Modify the state returning a value+modifyHS :: (HState -> (HState, a)) -> IO a+modifyHS f = modifyMVar hState (pure . f) <* setModified+
+ src/Style.hs view
@@ -0,0 +1,269 @@+-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- Copyright (c) 2019-2022, 2026 Galen Huntington+-- SPDX-License-Identifier: GPL-2.0-or-later++-- | Color manipulation++module Style where++import Base+import Text (SText)+import UI.HSCurses.Curses qualified as Curses+import Data.Map qualified as M++------------------------------------------------------------------------++-- | User-configurable colours+-- Each component of this structure corresponds to a fg\/bg colour pair+-- for an item in the ui+data UIStyle = UIStyle {+ window :: !Style -- default window colour+ , modals :: !Style -- help screen+ , titlebar :: !Style -- titlebar of window+ , selected :: !Style -- currently playing track+ , cursors :: !Style -- the scrolling cursor line+ , combined :: !Style -- the style to use when the cursor is on the current track+ , warnings :: !Style -- style for warnings+ , blockcursor :: !Style -- style for the block cursor when typing text+ , progress :: !Style -- style for the progress bar+ }++------------------------------------------------------------------------++-- | 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+ deriving stock (Eq,Ord)++-- | A styled text segment.+data Segment = Seg !Style {-# UNPACK #-} !SText++-- | A line of segments.+type Line = [Segment]++------------------------------------------------------------------------+-- | 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 $ 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++------------------------------------------------------------------------+-- | Set some colours, perform an action, and then reset the colours+withStyle :: Style -> IO () -> IO ()+withStyle sty fn = uiAttr sty >>= setAttribute >> fn >> reset+{-# INLINE withStyle #-}++-- | manipulate the current attributes of the standard screen+-- Only set attr if it's different to the current one?+setAttribute :: (Curses.Attr, Curses.Pair) -> IO ()+setAttribute = uncurry Curses.attrSet++-- | Reset the screen to normal values+reset :: IO ()+reset = setAttribute (Curses.attr0, Curses.Pair 0)++-- | And turn on the colours+initcolours :: UIStyle -> IO ()+initcolours sty = do+ let ls = [sty.modals, sty.warnings, sty.window,+ sty.selected, sty.titlebar, sty.progress,+ sty.blockcursor, sty.cursors, sty.combined ]+ Style fg bg = sty.progress -- bonus style+ pairs <- initUiColors (ls ++ [Style bg bg, Style fg fg])+ writeIORef pairMap pairs+ -- set the background+ uiAttr sty.window >>= \(_,p) -> Curses.bkgrndSet nullA p++------------------------------------------------------------------------+-- | Set up the ui attributes, given a ui style record+--+-- Returns an association list of pairs for foreground and bg colors,+-- associated with the terminal color pair that has been defined for+-- those colors.+--+initUiColors :: [Style] -> IO PairMap+initUiColors stys = do + ls <- sequence [ uncurry fn m | m <- zip stys [1..] ]+ pure (M.fromList ls)+ where+ fn :: Style -> Int -> IO (Style, (Curses.Attr,Curses.Pair))+ fn sty p = do+ let (CColor (a,fgc),CColor (b,bgc)) = style2curses sty+ discardErrors $ Curses.initPair (Curses.Pair p) fgc bgc+ pure (sty, (a `Curses.attrPlus` b, Curses.Pair p))++------------------------------------------------------------------------+-- | Getting from nice abstract colours to ncurses-settable values++-- 20% of allocss occur here! But there's only 3 or 4 colours :/+-- Every call to uiAttr+uiAttr :: Style -> IO (Curses.Attr, Curses.Pair)+uiAttr sty = do+ m <- readIORef pairMap+ pure $ lookupPair m sty++-- | Given a curses color pair, find the Curses.Pair (i.e. the pair+-- curses thinks these colors map to) from the state+lookupPair :: PairMap -> Style -> (Curses.Attr, Curses.Pair)+lookupPair m s =+ fromMaybe (Curses.attr0, Curses.Pair 0) (M.lookup s m)++-- | Keep a map of nice style defs to underlying curses pairs, created at init time+type PairMap = M.Map Style (Curses.Attr, Curses.Pair)++-- | map of Curses.Color pairs to ncurses terminal Pair settings+pairMap :: IORef PairMap+pairMap = unsafePerformIO $ newIORef M.empty+{-# NOINLINE pairMap #-}++------------------------------------------------------------------------+-- Basic (ncurses) colours.++defaultColor :: Curses.Color+defaultColor = fromJust $ Curses.color "default"++-- Combine attribute with another attribute+setBoldA, setReverseA :: Curses.Attr -> Curses.Attr+setBoldA = flip Curses.setBold True+setReverseA = flip Curses.setReverse True++-- | Some attribute constants+boldA, nullA, reverseA :: Curses.Attr+nullA = Curses.attr0+boldA = setBoldA nullA+reverseA = setReverseA nullA++------------------------------------------------------------------------++newtype CColor = CColor (Curses.Attr, Curses.Color)++-- | Map an abstract 'Style' to its ncurses foreground/background pair.+style2curses :: Style -> (CColor, CColor)+style2curses (Style fg bg) = (fgCursCol fg, bgCursCol bg)++-- | 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 = \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 = \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)++plainSeg :: SText -> Segment+plainSeg = Seg defaultSty++------------------------------------------------------------------------+-- Support for runtime configuration+-- We choose a simple strategy, read/showable record types, with strings+-- to represent colors+--+-- The fields must map to UIStyle+--+-- It is this data type that is stored in 'show' format in style.conf+--+data Config = Config {+ hmp3_window :: (String,String)+ , hmp3_modals :: (String,String)+ , hmp3_titlebar :: (String,String)+ , hmp3_selected :: (String,String)+ , hmp3_cursors :: (String,String)+ , hmp3_combined :: (String,String)+ , hmp3_warnings :: (String,String)+ , hmp3_blockcursor :: (String,String)+ , hmp3_progress :: (String,String)+ } deriving stock (Show,Read)++-- | Read style.conf, and construct a UIStyle from it, to insert into+buildStyle :: Config -> UIStyle+buildStyle bs = UIStyle {+ window = f bs.hmp3_window+ , modals = f bs.hmp3_modals+ , titlebar = f bs.hmp3_titlebar+ , selected = f bs.hmp3_selected+ , cursors = f bs.hmp3_cursors+ , combined = f bs.hmp3_combined+ , warnings = f bs.hmp3_warnings+ , blockcursor = f bs.hmp3_blockcursor+ , progress = f bs.hmp3_progress+ }+ where + f (x,y) = Style (g x) (g y)+ g x = fromMaybe Default $ stringToColor x++-- Built-in styles++defaultStyle :: UIStyle+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"+ }++monoStyle :: UIStyle+monoStyle = UIStyle+ { 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"+ }+
+ src/Text.hs view
@@ -0,0 +1,164 @@+-- Copyright (c) 2019-2026 Galen Huntington+-- SPDX-License-Identifier: GPL-2.0-or-later++-- This module provides basic text string functions.++module Text (+ SText, matches,+ trim, spaces, guessEncoding, dropLastUTF8,+ readIntM, showInt, show02d,+ width, toMaxWidth, toWidth,+ fromBS, toBS, fromChar,+ notNull, encodeFS,isLineSafe,+) where++import Base++import Data.ByteString.Char8 qualified as P+import Data.ByteString.UTF8 qualified as UTF8+import Foreign.C.Types (CWchar(..), CInt(..))+import GHC.Foreign qualified as GHC+import GHC.IO.Encoding (getFileSystemEncoding)+import Text.Regex.Posix (match, makeRegexOptsM, compIgnoreCase, compExtended, compNoSub)+++-- SText type and functions.++-- | Screen/Sanitized/Safe text:+-- A string of valid UTF-8 with only printable characters.+data SText = SText+ { string :: !ByteString+ , width :: !Int+ } deriving stock (Eq, Show)++instance Semigroup SText where+ s <> t = SText (s.string <> t.string) (s.width + t.width)+instance Monoid SText where+ mempty = SText "" 0+ mconcat l = SText (P.concat $ map (.string) l) (sum $ map (.width) l)+instance IsString SText where+ fromString s = let bs = UTF8.fromString $ toPrintable s in SText bs (stringWidth bs)++toBS :: SText -> ByteString+toBS = (.string)++width :: SText -> Int+width = (.width)++spaces :: Int -> SText+spaces n | n > 0 = SText (P.replicate n ' ') n+ | True = ""++-- More convenient than null, I find.+notNull :: SText -> Bool+notNull = not . P.null . (.string)++-- | Swappable API for searching+matches :: SText -> Maybe (SText -> Bool)+matches (SText s _) =+ match' <$> makeRegexOptsM (compIgnoreCase + compExtended + compNoSub) 0 s+ where match' re (SText bs _) = match re bs++-- | Possible number.+readIntM :: SText -> Maybe Int+readIntM = fmap fst . P.readInt . toBS++showInt :: Int -> SText+showInt = unsafeFromAsciiBS . P.pack . show++-- | Show Int from 0 to 99 as two digits.+show02d :: Int -> SText+show02d n = SText (P.pack [dtc d1, dtc d0]) 2 where+ (d1, d0) = (n `mod` 100) `quotRem` 10+ dtc = toEnum . (48 +)++replacementChar :: Char+replacementChar =+ if charWidth UTF8.replacement_char == 1 then UTF8.replacement_char else '='++-- | If seeming ISO-8859-1, convert to UTF-8.+guessEncoding :: ByteString -> SText+guessEncoding bs =+ if UTF8.replacement_char `elem` UTF8.toString bs+ then fromString $ P.unpack bs else fromBS bs++-- | Test if printable according to wcwidth.+isPrintable :: Char -> Bool+isPrintable c = c /= '\0' && charWidth c >= 0++-- | Blot out control and other unprintable characters.+toPrintable :: String -> String+toPrintable = map \c -> if isPrintable c then c else replacementChar++-- | ByteString to displayable text.+-- Pre-checks for common case of already printable.+fromBS :: ByteString -> SText+fromBS bs = SText s (stringWidth s) where+ (_, bad) = UTF8.span (\c -> c /= UTF8.replacement_char && isPrintable c) bs+ s = if P.null bad then bs else UTF8.fromString $ toPrintable $ UTF8.toString bs++unsafeFromAsciiBS :: ByteString -> SText+unsafeFromAsciiBS s = SText s (P.length s)++fromChar :: Char -> SText+fromChar c = SText (UTF8.fromChar c') (charWidth c')+ where c' = if isPrintable c then c else replacementChar+++-- ByteString utilities.++-- | Strip leading and trailing whitespace.+trim :: ByteString -> ByteString+trim = P.dropWhileEnd isSpace . P.dropSpace++-- | Drop last UTF-8 codepoint.+dropLastUTF8 :: ByteString -> ByteString+dropLastUTF8 = P.dropEnd 1 . P.dropWhileEnd isCB+ where isCB b = b >= '\128' && b < '\192'++-- | Can file be sent to decoder?+isLineSafe :: ByteString -> Bool+isLineSafe = P.all (`notElem` ['\0', '\r', '\n'])++-- XXX when we drop GHC 9.4 we can use its filepath's function+-- | Filesystem encoding for CLI (PEP 383).+encodeFS :: String -> IO ByteString+encodeFS str = do+ enc <- getFileSystemEncoding+ GHC.withCStringLen enc str P.packCStringLen+++-- Width operations on 'SText', using libc 'wcwidth'.+-- A UTF-8 runtime locale is presumed; counts may differ otherwise.++-- | 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 -> SText -> SText+toMaxWidth = sizer False+toWidth = sizer True++ellipsis :: ByteString+ellipsis = if charWidth '…' == 1 then UTF8.fromChar '…' else "-"++sizer :: Bool -> Int -> SText -> SText+sizer pad w s@(SText bs dw)+ | dw <= w = if pad then s <> spaces (w-dw) else s+ | True = SText (walk 0 bs) w+ where+ walk !l rest+ | l' >= w = P.take (P.length bs - P.length rest) bs+ <> mconcat (replicate (w-l) ellipsis)+ | True = walk l' rest'+ where+ (c, rest') = fromJust $ UTF8.uncons rest -- can't be at end since dw>w+ l' = l + charWidth c++stringWidth :: ByteString -> Int+stringWidth = UTF8.foldl (\acc c -> acc + charWidth c) 0++charWidth :: Char -> Int+charWidth = fromIntegral . wcwidth . toEnum . fromEnum++foreign import ccall unsafe+ wcwidth :: CWchar -> CInt+
+ src/UI.hs view
@@ -0,0 +1,363 @@+-- 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. ++module UI (+ runDraw,+ start, end, screenSize, refresh, refreshClock, resetui,+ getKey,+ ) where++import Base+import Elements as El+import Style+import Playlist (File(dir, text), Dir(text))+import State+import Decoder+import Text+import UI.HSCurses.Curses qualified as Curses+import Keyboard (unkey)++import Data.Array ((!), bounds, Array)+import Data.Array.Base (unsafeAt)+import Data.ByteString.Char8 qualified as P+import Data.ByteString.Unsafe qualified as P+import System.IO (stderr, hFlush)+import System.Posix.Signals (installHandler, Handler(..))++import Foreign.C.Error (Errno(..), getErrno)+import Foreign.C.String+import Foreign.C.Types (CInt(..))+++newtype Draw = Draw (IO ())+ deriving newtype (Semigroup, Monoid)++drawLock :: MVar ()+drawLock = unsafePerformIO $ newMVar ()+{-# NOINLINE drawLock #-}++runDraw :: Draw -> IO ()+runDraw (Draw io) = withMVar drawLock $ const io++------------------------------------------------------------------------++-- | Initialize the UI+start :: IO UIStyle+start = do+ Curses.initCurses++ case Curses.cursesSigWinch of+ Just wch -> void $ installHandler wch (Catch resetui) Nothing+ _ -> pure () -- handled elsewhere++ colorify <- Curses.hasColors+ let sty = if colorify then defaultStyle else monoStyle++ initcolours sty+ Curses.keypad Curses.stdScr True -- grab the keyboard+ runDraw nocursor++ pure sty++-- | Reset+resetui :: IO ()+resetui = runDraw (resizeui <> nocursor) *> refresh++-- | And force invisible+nocursor :: Draw+nocursor = Draw $ discardErrors $ void $ Curses.cursSet Curses.CursorInvisible++-- | Clean up and go home.+end :: IO ()+end = do+ takeMVar drawLock -- we keep so no one tries to draw+ setXtermTitle ["xterm"] -- XXX I don't see this title after exit?+ Curses.endWin++-- | Find the current screen height and width.+screenSize :: IO (Int, Int)+screenSize = Curses.scrSize++-- | Rewrite of Curses.getCh to avoid looping on terminal crash+-- | (also no unget support since I don't need it)+getCh :: IO Curses.Key+getCh = do+ threadWaitRead 0+ v <- Curses.getch+ case v of+ -1 -> do+ Errno e <- getErrno+ putStrLn $ "Error " ++ show e ++ "; terminal has gone away? Hard-exiting now."+ exitFailure+ k -> pure $ Curses.decodeKey k++-- | Read a key. UIs need to define a method for getting events.+-- We only need to refresh if we don't have no SIGWINCH support.+getKey :: IO Char+getKey = do+ k <- getCh+ if k == Curses.KeyResize + then do+ when (isNothing Curses.cursesSigWinch) do+ runDraw $ redraw <> resizeui+ getKey+ else pure $ unkey k++-- | Resize the window+-- From "Writing Programs with NCURSES", by Eric S. Raymond and Zeyd M. Ben-Halim+resizeui :: Draw+resizeui = Draw do+ Curses.endWin+ Curses.resetParams+ do+ -- not sure I need all these...+ Curses.nl True+ _ <- Curses.leaveOk True+ Curses.noDelay Curses.stdScr False+ Curses.cBreak True+ -- Curses.meta stdScr True -- not in module+ -- not sure about intrFlush, raw - set in hscurses+ Curses.refresh+ void Curses.scrSize++refresh :: IO ()+refresh = runDraw $ redraw <> Draw Curses.refresh++refreshClock :: IO ()+refreshClock = runDraw $ redrawJustClock <> Draw Curses.refresh++------------------------------------------------------------------------++data DrawData = DD { drawWidth :: !Int, drawState :: !HState }++------------------------------------------------------------------------++-- | Info about the current track+pPlaying :: DrawData -> Line+pPlaying dd = pure $ plainSeg $ " " <> mconcat line where+ x = dd.drawWidth+ a = pId3 dd+ b = fromMaybe "" dd.drawState.info -- mp3 info+ line | gap >= 0 = a : spaces gap : right+ | True = toMaxWidth lim a : right+ where lim = x - 5 - (if showId3 then width b else -1)+ gap = lim - width a+ showId3 = x > 59+ right = if showId3 then [" ", b] else []++-- | Id3 info+pId3 :: DrawData -> SText+pId3 DD{drawState=st} = maybe (st.music ! st.current).text (.str) st.id3++------------------------------------------------------------------------++-- | Show progress bar.+progressBar :: DrawData -> Line+progressBar (DD w st) = [+ plainSeg " ", Seg (Style fg fg) (spaces x), Seg sty (spaces (w'-x)) ]+ where+ w' = w - 4+ x = El.progress w' st.clock+ sty@(Style fg _) = st.uiStyle.progress++-- | Two lines showing clock.+clockLines :: DrawData -> [Line]+clockLines dd@(DD w st) = [progressBar dd, [plainSeg (El.pTimes w st.clock)]]++------------------------------------------------------------------------++-- | Play state+pState :: DrawData -> String+pState dd = case dd.drawState.status of+ Stopped -> "◼"+ Paused -> "⏸"+ Playing -> "▶"++-- | Play mode+pMode :: DrawData -> String+pMode dd = take 4 $ map toLower $ show dd.drawState.mode++------------------------------------------------------------------------++-- | "x/n dirs y/m files" cursor position read-out.+playInfo :: DrawData -> SText+playInfo DD{drawState=st} = mconcat+ [ spaces (width numd - width curd)+ , curd, "/", numd, " dirs"+ , spaces (1 + width numf - width curf)+ , curf, "/", numf, " files"+ ]+ where+ curf = showInt $ st.cursor + 1+ numf = showInt $ st.size+ curd = showInt $ (st.music ! st.cursor).dir + 1+ numd = showInt $ length $ st.folders++-- | The top title bar: cursor position + play indicator + uptime + version.+playTitle :: DrawData -> Line+playTitle dd@DD{drawWidth=w, drawState=st} =+ [Seg st.uiStyle.titlebar $ El.layoutLCR w (left, centerS, right)]+ where+ left = " " <> playInfo dd+ centerS = pState dd ++ ' ' : pMode dd -- always 6 chars+ right = st.uptime <> " " <> El.pVersion <> " "++-- | The scrolling playlist (visible tracks).+playList :: Int -> DrawData -> [Line]+playList buflen _ | buflen <= 0 = [] -- extra defense besides laziness+playList buflen DD{ drawWidth=w, drawState=st } =+ list ++ replicate (buflen - length list) []++ where+ -- number of screens down, and then offset+ (screens, select) = st.cursor `quotRem` buflen -- keep cursor in screen+ playing = st.current - screens * buflen -- invisible if out of bounds++ -- visible slice of the playlist+ visible = slice off (off + buflen - 1) st.music+ where off = screens * buflen++ visible' :: [(Maybe Int, SText)]+ visible' = loop (-1) visible where+ loop _ [] = []+ loop n (v:vs) =+ let r = if v.dir > n then Just v.dir else Nothing+ in (r, toMaxWidth (w - indent - 1) v.text) : loop v.dir vs++ list = [ drawIt . color $ n | n <- zip visible' [0..] ]++ indent = round $ st.folderCol * fromIntegral (w - 1) :: Int++ (sty1, sty2, sty3) = (cs.selected, cs.cursors, cs.combined)+ where cs = st.uiStyle++ color :: ((Maybe Int, SText), Int) -> (Maybe Int, (Style, [SText]))+ 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 (w - indent - 1 - width s)])++ drawIt :: (Maybe Int, (Style, [SText])) -> Line+ drawIt (Nothing, (sty, v)) =+ map (Seg sty) $ spaces (1 + indent) : v+ drawIt (Just i, (sty, v)) = Seg sty' d+ : Seg sty' (spaces (indent + 1 - width d))+ : map (Seg sty) v+ where+ sty' = if sty == sty2 || sty == sty3 then sty2 else sty1+ d = toMaxWidth (indent - 1) (st.folders ! i).text++------------------------------------------------------------------------+-- | Write out only the clock lines.+redrawJustClock :: Draw+redrawJustClock = Draw $ discardErrors do+ st <- getsHS id+ (h, w) <- screenSize+ drawFullLines (h-1) 1 $ clockLines $ DD w st++------------------------------------------------------------------------+-- | General modal renderer.+renderModal :: HState -> (Int, Int) -> ModalMaker -> IO ()+renderModal st (h, w) mkr = do+ let (mw, modal') = mkr w+ hoffset = max 0 $ (w - mw) `div` 2+ vislines = (h - 5) `min` length modal'+ voffset = ((h - vislines) `div` 2) `max` 4+ for_ (zip [voffset..] $ take vislines modal') \ (y, t) -> do+ Curses.wMove Curses.stdScr y hoffset+ drawSegment $ Seg st.uiStyle.modals (toWidth mw t)++-- | Choose modal to render based on state.+renderModals :: HState -> (Int, Int) -> IO ()+renderModals st sz =+ whenJust st.modal $ renderModal st sz . \case+ HelpModal h -> El.helpModal h+ HistModal h -> El.histModal h+ ExitModal -> El.exitModal++------------------------------------------------------------------------+-- | Draw the screen+-- Errors can maybe be thrown if screen gets resized mid-render.+redraw :: Draw+redraw = Draw $ discardErrors do+ st <- getsHS id+ sz@(h, w) <- screenSize+ setXterm st+ drawFullLines (h-1) 0 $ let dd = DD w st in+ pPlaying dd : clockLines dd ++ playTitle dd : playList (h-5) dd+ renderModals st sz+ -- minibuffer+ Curses.wMove Curses.stdScr (h-1) 0+ drawLine st.minibuffer+ when st.miniFocused do -- a fake cursor+ drawSegment $ Seg st.uiStyle.blockcursor " "+ fillLine++-- | Render whole lines without going below limit.+drawFullLines :: Int -> Int -> [Line] -> IO ()+drawFullLines limit y ls =+ for_ (zip [y .. limit-1] ls) \ (y', t) -> do+ Curses.wMove Curses.stdScr y' 0+ drawLine t *> fillLine++------------------------------------------------------------------------+-- | Draw a styled line to the screen+drawLine :: Line -> IO ()+drawLine = traverse_ drawSegment++-- | Write a single styled text segment.+drawSegment :: Segment -> IO ()+drawSegment (Seg sty s) = withStyle sty $ drawText s++-- | Draw text to Curses. Safe because C only reads the bytes.+drawText :: SText -> IO ()+drawText s = void $+ P.unsafeUseAsCStringLen (toBS s) \(cstr, len) ->+ waddnstr Curses.stdScr cstr (fromIntegral len)++------------------------------------------------------------------------++-- | Fill to end of line spaces+-- (Curses throws error if already at end.)+fillLine :: IO ()+fillLine = discardErrors Curses.clrToEol++-- | Take a slice of an array efficiently+slice :: Int -> Int -> Array Int e -> [e]+slice i j arr = + let (a, b) = bounds arr+ in [unsafeAt arr n | n <- [max a i .. min b j]]++------------------------------------------------------------------------++-- | Set xterm title with ANSI escape sequence.+setXtermTitle :: [SText] -> IO ()+setXtermTitle strs = do+ traverse_ (P.hPut stderr) (before : map toBS strs ++ [after])+ hFlush stderr+ where+ before = "\ESC]0;"+ after = "\007"++-- set xterm title. Don't need to do this on each refresh...+setXterm :: HState -> IO ()+setXterm st = setXtermTitle case st.status of+ Playing -> case st.id3 of+ Just id3 -> id3.artist :+ if id3.title == "" then [] else [": ", id3.title]+ _ -> [(st.music ! st.current).text]+ Paused -> ["paused"]+ Stopped -> ["stopped"]++foreign import ccall safe+ waddnstr :: Curses.Window -> CString -> CInt -> IO CInt+
test/ElementsSpec.hs view
@@ -7,12 +7,30 @@ import System.Clock (TimeSpec(..)) import Base-import Text (displayWidth)-import Elements (showDuration, fitLCR, layoutLCR, Fit(..))+import Text (width, fromBS)+import Elements (showClock, showDuration, fitLCR, layoutLCR, Fit(..)) tests :: TestTree tests = testGroup "Elements"- [ testGroup "showDuration (showSecs=False)"+ [ testGroup "showClock"+ [ testCase "zero"+ $ showClock 0 @?= "0:00.0"+ , testCase "seconds are zero-padded"+ $ showClock 9.99 @?= "0:09.9"+ , testCase "hundredths are truncated"+ $ showClock 0.09 @?= "0:00.0"+ , testCase "ten seconds"+ $ showClock 10 @?= "0:10.0"+ , testCase "just before one minute"+ $ showClock 59.99 @?= "0:59.9"+ , testCase "exactly one minute"+ $ showClock 60 @?= "1:00.0"+ , testCase "minutes, seconds, and tenths"+ $ showClock 61.23 @?= "1:01.2"+ , testCase "hours are displayed as total minutes"+ $ showClock 3600 @?= "60:00.0"+ ]+ , testGroup "showDuration (showSecs=False)" [ testCase "under a minute is 0m" $ showDuration False (t 30) @?= "0m" , testCase "exactly one minute"@@ -68,7 +86,8 @@ let a = padL + (if wide then lsz else 0) b = padR + (if wide then rsz else 0) in a == b || a + 1 == b- let s = layoutLCR w (P.replicate lsz 'x', replicate csz 'x', P.replicate rsz 'x')- assertEqual ("String width: " ++ show inp ++ " -> " ++ show s) w- $ displayWidth s-+ let s = layoutLCR w (+ fromBS $ P.replicate lsz 'x',+ replicate csz 'x',+ fromBS $ P.replicate rsz 'x')+ assertEqual ("String width: " ++ show inp ++ " -> " ++ show s) w $ width s
test/TextSpec.hs view
@@ -3,7 +3,10 @@ import Test.Tasty import Test.Tasty.HUnit +import Base import Text+import Data.ByteString.UTF8 qualified as UTF8+import Data.ByteString.Unsafe qualified as P -- These tests depend on wcwidth's behavior under a UTF-8 locale and on a -- handful of codepoints whose canonical widths are well-known:@@ -28,7 +31,7 @@ , m (Just True) "dot CJK" "中.人" "中國人" , m (Just False) "byte dots" "c..te" "côte" ]- , testGroup "dropLastUTF8"+ , testGroup "dropLastUTF8" $ let u = UTF8.fromString in [ testCase "ASCII" $ dropLastUTF8 "abc" @?= "ab" , testCase "empty" $ dropLastUTF8 "" @?= "" , testCase "French" $ dropLastUTF8 (u"été") @?= u"ét"@@ -41,16 +44,17 @@ , testCase "whitespace" $ trim " \tfoo bar \n" @?= "foo bar" ] , testGroup "guessEncoding"- [ testCase "ASCII" $ guessEncoding "abc" @?= "abc"- , testCase "ISO-8859" $ guessEncoding "encöde" @?= u"encöde"- , testCase "UTF-8" $ guessEncoding (u"encöde") @?= u"encöde"+ [ testCase "ASCII" $ guessEncoding "abc" @?= "abc"+ , testCase "ISO-8859" $ guessEncoding "encöde" @?= "encöde"+ , testCase "UTF-8" $ guessEncoding "encöde" @?= "encöde"+ , testCase "control" $ guessEncoding "en\3öde" @?= "en�öde" ]- , 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 "width"+ [ testCase "empty" $ width "" @?= 0+ , testCase "ascii" $ width "hello" @?= 5+ , testCase "latin-extended" $ width "café" @?= 4+ , testCase "cjk doubles each" $ width "中文" @?= 4+ , testCase "mixed" $ width "中a文b" @?= 6 ] , testGroup "toMaxWidth" [ testCase "wider than input passes through"@@ -58,21 +62,21 @@ , testCase "exactly the width passes through" $ toMaxWidth 5 "hello" @?= "hello" , testCase "truncate ascii with ellipsis"- $ toMaxWidth 4 "hello" @?= "hel" <> u"…"+ $ toMaxWidth 4 "hello" @?= "hel" <> "…" , testCase "narrower truncate"- $ toMaxWidth 2 "hello" @?= "h" <> u"…"+ $ toMaxWidth 2 "hello" @?= "h" <> "…" , testCase "width one becomes a lone ellipsis"- $ toMaxWidth 1 "hello" @?= u"…"+ $ toMaxWidth 1 "hello" @?= "…" , 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"中……"+ $ toMaxWidth 4 "中文hi" @?= "中……" , 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"中…"+ $ toMaxWidth 3 "中文" @?= "中…" ] , testGroup "toWidth" [ testCase "pads short ascii"@@ -82,13 +86,30 @@ , testCase "exact width unchanged" $ toWidth 5 "hello" @?= "hello" , testCase "truncate matches toMaxWidth when over-width"- $ toWidth 4 "hello" @?= u"hel…"+ $ toWidth 4 "hello" @?= "hel…" , testCase "pads after a wide-char content too"- $ toWidth 5 (u"中a") @?= u"中a "+ $ toWidth 5 "中a" @?= "中a " ]+ , testGroup "fromBS"+ [ testCase "Unicode" $ fromBS (UTF8.fromString "encöde") @?= "encöde"+ , testCase "bad bytes" $ fromBS "no\130b\8y" @?= "no�b�y"+ , testCase "worse bytes" $ fromBS "no\130bsy" @?= "no�bsy"+ , testCase "control" $ fromBS "nob\8dy" @?= "nob�dy"+ , testCase "no dupe" $+ let bs = UTF8.fromString "schőn" in eqRef bs (toBS $ fromBS bs)+ ]+ , testGroup "spaces"+ [ testCase "two" $ spaces 2 @?= " "+ , testCase "negative" $ spaces (-1) @?= ""+ ] ] -m :: Maybe Bool -> String -> String -> String -> TestTree-m b tag pat str = testCase tag $ ($ u str) <$> matches (u pat) @?= b+m :: Maybe Bool -> String -> SText -> SText -> TestTree+m b tag pat str = testCase tag $ ($ str) <$> matches pat @?= b++-- Test memory reuse.+eqRef :: ByteString -> ByteString -> Assertion+eqRef a b =+ P.unsafeUseAsCStringLen a \a' -> P.unsafeUseAsCStringLen b \b' -> a' @?= b'