hmp3-ng 2.19.0 → 2.19.1
raw patch · 22 files changed
+940/−1041 lines, 22 filesdep +transformers
Dependencies added: transformers
Files
- Base.hs +10/−36
- Config.hs +0/−75
- Core.hs +198/−219
- Decoder.hs +25/−46
- Elements.hs +149/−0
- Keymap.hs +54/−49
- State.hs +50/−19
- Style.hs +51/−49
- Text.hs +89/−0
- UI.hs +99/−301
- Width.hs +0/−45
- app/Main.hs +4/−3
- hmp3-ng.cabal +9/−9
- test/BaseSpec.hs +0/−30
- test/ConfigSpec.hs +0/−35
- test/CoreSpec.hs +0/−44
- test/DecoderSpec.hs +7/−8
- test/ElementsSpec.hs +74/−0
- test/Main.hs +4/−8
- test/StyleSpec.hs +23/−0
- test/TextSpec.hs +94/−0
- test/WidthSpec.hs +0/−65
Base.hs view
@@ -13,6 +13,7 @@ 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)@@ -30,7 +31,6 @@ import System.IO.Unsafe as X import Text.Printf as X import Text.Read as X (readMaybe)-import Text.Regex.Posix (match, makeRegexOptsM, compIgnoreCase, compExtended) import System.Clock @@ -50,41 +50,15 @@ (!?) :: [a] -> Int -> Maybe a xs !? n = listToMaybe $ drop n xs ---- API for searching-matches :: ByteString -> ByteString -> Bool---- Layer allowing switching back end--{---- pcre-light version (can't use currently due to pcre3 dep)-matches s = case compileM s [caseless, utf8] of- Right p -> \t -> isJust $ match p t []- _ -> const False--}--{---- regex-pcre2 version (fails to build in CI, not in Stackage)-matches s = case makeRegexOptsM compCaseless 0 s of- Just p -> match p- _ -> const False--}--{---- pcre2 version (inefficient, mass Text conversion, ugly)--- needs text dep/import-matches s =- let p = decodeUtf8Lenient s- in \t -> unsafePerformIO- $ handle @SomeException (const $ pure False) $ evaluate- $ matchesOpt Caseless p (decodeUtf8Lenient t)--}+-- | Zipper structure, representing a list with a cursor.+data Zipper a = Zipper { cur :: !a, back :: ![a], front :: ![a] } --- regex-posix version (reputed to be slow and buggy)-matches s = maybe (const False) match $- makeRegexOptsM (compIgnoreCase + compExtended) 0 s+zipEdit :: (a -> a) -> Zipper a -> Zipper a+zipEdit f z = z { cur = f z.cur } --- not yet tried:--- regex-tdfa (mass Text conversion, parsec dep) text import--- regex-dfa (not in Stackage, unknown engine)+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
− Config.hs
@@ -1,75 +0,0 @@--- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019-2021, 2026 Galen Huntington--- SPDX-License-Identifier: GPL-2.0-or-later--module Config where--import Data.Map qualified as M--import Base-import Style-import Paths_hmp3_ng (version)---- XXX some styles are currently unused, but planned is a CLI option to select--fixedStyles :: M.Map String UIStyle-fixedStyles = M.fromList- [ ("default", defaultStyle)- , ("dark", defaultStyle)- , ("light", lightBgStyle)- , ("mono", bwStyle)- , ("mutt", muttStyle)- ]--defaultStyle :: UIStyle-defaultStyle = UIStyle { window = style "default" "default"- , titlebar = style "brightwhite" "green"- , selected = style "blue" "default"- , cursors = style "black" "cyan"- , combined = style "brightwhite" "cyan"- , warnings = style "red" "default"- , modals = style "black" "white"- , blockcursor= style "black" "red"- , progress = style "cyan" "white" }---- | A style more suitable for light backgrounds-lightBgStyle :: UIStyle-lightBgStyle =- defaultStyle { selected = style "darkblue" "default"- , warnings = style "darkred" "default" }------- | Another style for dark backgrounds, reminiscent of mutt----muttStyle :: UIStyle-muttStyle = UIStyle { window = style "brightwhite" "black"- , titlebar = style "green" "blue"- , selected = style "brightwhite" "black"- , cursors = style "black" "cyan"- , combined = style "black" "cyan"- , warnings = style "brightwhite" "red"- , modals = style "black" "cyan"- , blockcursor= style "black" "darkred"- , progress = style "cyan" "white" }--bwStyle :: UIStyle-bwStyle = 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"- }----------------------------------------------------------------------------package :: String-package = "hmp3-ng"--versinfo :: String-versinfo = package ++ " v" ++ showVersion version-
Core.hs view
@@ -8,18 +8,17 @@ module Core ( Options(..), start, shutdown,- seekLeft, seekRight, upOne, downOne, pause, nextMode, playNext, playPrev,+ upOne, downOne, pause, nextMode, playNext, playPrev, forcePause, putMessage, clearMessage, playCursor, playCur,- jumpToPlaying, jump, jumpRel,+ jumpToPlaying, jump, jumpRel, jumpRandom, upPage, downPage,- seekStart,+ seek, seekStart, adjFolderCol, blacklist, setsModal, closeModal, showHist,- jumpToMatchDir, jumpToMatchFile,+ search, repeatSearch, toggleFocus, jumpToNextDir, jumpToPrevDir, loadConfig, discardErrors,- showTimeDiff_, ) where import Base@@ -28,7 +27,9 @@ 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@@ -36,89 +37,90 @@ 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.Clock (TimeSpec(..), diffTimeSpec) import System.Random (randomR, newStdGen)-import System.FilePath ((</>))-import System.Posix.FilePath (takeFileName)-+import System.FilePath qualified as FP ((</>))+import System.Posix.FilePath (takeFileName, (</>)) import System.Posix.Process (exitImmediately) -mp3Tool :: String-mp3Tool = "mpg123"- ------------------------------------------------------------------------ -- | Command-line configuration. data Options = Options- { optPaused :: !Bool -- ^ start in a paused state- , optConfigPath :: !(Maybe FilePath) -- ^ override the style.conf location- , optPlayMode :: Maybe Mode -- ^ play mode- , optHistSize :: Int -- ^ history size+ { 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 - config <- catch @SomeException UI.start \err -> do- -- An uncaught exception here would deadlock.- -- XXX more state model revisions should obviate need- hPutStrLn stderr $ "Curses failed to start: " ++ show err- exitImmediately $ ExitFailure 1+ uiStyle <- UI.start bootTime <- getMonoTime- let size = length music- mode <- maybe readState pure (optPlayMode opts)+ mode <- maybe readState pure opts.playMode gen <- newStdGen- let (current, randomGen) =- if mode == Random then randomR (0, size-1) gen else (0, gen)-- threads <- traverse forkIO- [ mpgLoop- , mpgInput- , refreshLoop- , uptimeLoop- ]+ let (current, randomGen) = if mode == Random || opts.random+ then randomR (0, length music - 1) gen else (0, gen) putMVar hState HState { music , folders- , size , bootTime- , configPath = optConfigPath opts+ , configPath = opts.configPath , current , cursor = current , randomGen , mode- , config- , threads+ , uiStyle , spawns = 0- , mpgPid = Nothing , clock = Nothing , info = Nothing , id3 = Nothing , modal = Nothing , playHist = mempty , searchHist = []- , searchFw = True- , histSize = optHistSize opts+ , searchType = SearchType True True+ , folderCol = 0.334+ , histSize = opts.histSize , miniFocused = False- , exiting = False , status = Stopped- , minibuffer = Fast mempty defaultSty+ , minibuffer = [] , uptime = mempty } loadConfig -- TODO this should return config rather than setting it - playCur- when (optPaused opts) pause -- TODO use LOADPAUSED?+ 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@@ -143,49 +145,34 @@ ------------------------------------------------------------------------ --- | Process loop, launch mpg123, set the handles in the state--- and then wait for the process to die. If it does, restart it.------ If we're unable to start at all, we should say something sensible--- For example, if we can't start it two times in a row, perhaps give up?---+-- | Loop, launching decoder and updating global state. mpgLoop :: IO () mpgLoop = runForever do- mmpg <- findExecutable mp3Tool- case mmpg of- Nothing -> shutdown $ Just $ "Cannot find " ++ mp3Tool ++ " in path"- Just mppath -> do- mv <- try $ runInteractiveProcess mppath ["-R", "--remote-err"] Nothing Nothing- case mv of- Left (ex :: SomeException) ->- warnA $ mppath ++ " failed to start; retrying: " ++ show ex-- Right (writeh, _, errh, pid) -> do- ct <- modifyHS $ \st -> let sp = spawns st + 1 in (st- { mpgPid = Just pid- , status = Stopped+ 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)-- putMVar mpg Mpg { errh, writeh }- when (ct > 1) $ warnA $ mp3Tool ++ " #" ++ show ct ++ ": Ready"- catch @SomeException (void $ waitForProcess pid) (const $ pure ())-- -- Must be in this order or risk shutdown deadlock!- silentlyModifyHS $ \st -> st { mpgPid = Nothing }- void $ takeMVar mpg-- stop <- getsHS exiting- when stop exitSuccess+ overseeMpg handles threadDelay 1_000_000 -- let threads spit errors- warnA $ "Restarting " ++ mppath ++ " ..."-- -- Slow spawn loops in case of trouble.- threadDelay 4_000_000-+ warnA $ "Restarting " ++ mp3Tool ++ " ..."+ threadDelay 4_000_000 -- rate-limit respawns ------------------------------------------------------------------------ @@ -194,124 +181,103 @@ 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+uptimeLoop = runForever do now <- getMonoTime- modifyHS_ $ \st -> st { uptime = showTimeDiff (bootTime st) now }- threadDelay 3_000_000----------------------------------------------------------------------------showTimeDiff_ :: Bool -> TimeSpec -> TimeSpec -> ByteString-showTimeDiff_ secs before now- | ms == 0 && secs- = 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- stot = sec $ diffTimeSpec before now- (ms,s) = quotRem stot 60- (hs,m) = quotRem ms 60- (d,h) = quotRem hs 24- ss = if secs then (<> printf (if ms > 0 then "%02ds" else "%ds") s) else id--showTimeDiff :: TimeSpec -> TimeSpec -> ByteString-showTimeDiff = showTimeDiff_ False+ μ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, so we--- take that chance to exit.---+-- shutdown kills the other end of the pipe, hGetLine will fail. mpgInput :: IO () mpgInput = runForever $ do- line <- P.hGetLine =<< errh <$> readMVar mpg+ line <- P.hGetLine =<< readMVar mpgRead case mpgParser line of Right m -> handleMsg m- Left (Just e) -> warnA ("mpg123: " ++ e)+ Left (Just e) -> warnA (mp3Tool ++ ": " ++ e) _ -> pure () ------------------------------------------------------------------------ -- | Close most things. Important to do all the jobs:--- TODO maybe releaseSignals here? shutdown :: Maybe String -> IO () shutdown ms = do UI.end- silentlyModifyHS $ \st -> st { exiting = True }- discardErrors writeState- mpid <- getsHS mpgPid- whenJust mpid \pid -> do- discardErrors $ sendMpg Quit- void $ waitForProcess pid+ 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 --------------------------------------------------------------------------- --- Write incoming messages from the encoder to the global state in the--- right pigeon hole.----handleMsg :: Msg -> IO ()--handleMsg (S i) = modifyHS_ $ \s -> s { info = Just i }--handleMsg (I id3) = modifyHS_ $ \s -> s { id3 = Just id3 }--handleMsg (P t) = do- modifyHS_ $ \s -> s { status = t }- when (t == Stopped) playNext -- transition to next song+-- 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--- --- | Seek backward in song-seekLeft :: IO ()-seekLeft = seek \g -> max 0 (currentFrame g - 400)---- | Seek forward in song-seekRight :: IO ()-seekRight = seek \g -> currentFrame g + min 400 (framesLeft g)+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 $ const 0+seekStart = seek $ fromIntegral $ minBound @Int --- | Generic seek-seek :: (Frame -> Int) -> IO ()-seek fn = do- mfr <- getsHS clock- whenJust mfr \fr -> sendMpg $ Jump $ fn fr+-- | 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 (cursor st) `min` (size st - 1)) `max` 0 }+ 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)+downOne = jumpFn (+ 1) page :: Int -> IO () page dir = do (sz, _) <- UI.screenSize- jumpFn (+ dir*(sz-5))+ jumpFn (+ dir*(1`max`(sz-5))) upPage, downPage :: IO () upPage = page (-1)@@ -325,15 +291,15 @@ jumpRel :: Rational -> IO () jumpRel r | r < 0 || r >= 1 = pure () | True = modifyHS_ $ \st ->- st { cursor = floor $ fromIntegral (size st) * r }+ 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 = music st ! cursor st- in P.intercalate (P.singleton '/') [dname $ folders st ! fdir fe, fbase fe]+ let fe = st.music ! st.cursor+ in (st.folders ! fe.fdir).dname </> fe.fbase ------------------------------------------------------------------------ @@ -348,20 +314,20 @@ -- | Play the song under the cursor (from the start) playCur :: IO ()-playCur = runPlayOp $ Just <$> gets cursor+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- HState { mode, size, current } <- get- case mode of+ st <- get+ case st.mode of Random -> playRandomOp Single -> pure Nothing- _ | current > 0- -> pure $ Just $ current - 1- Loop -> pure $ Just $ size - 1+ _ | 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@@ -372,24 +338,35 @@ playNextOp :: PlayOp playNextOp = do- HState { mode, current, size } <- get- let next = current + 1- case mode of+ st <- get+ let next = st.current + 1+ case st.mode of Random -> playRandomOp Single -> pure Nothing- _ | next < size+ _ | 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 = do- HState { size, randomGen } <- get- let (new, gen') = randomR (0, size-1) randomGen- modify' \st -> st { randomGen = gen' }- pure $ Just new+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 ()@@ -400,14 +377,14 @@ forM mnew \new -> do HState { .. } <- get let fe = music ! new- f = P.intercalate (P.singleton '/')- [dname $ folders ! fdir fe, fbase fe]+ f = (folders ! fe.fdir).dname </> fe.fbase modify' \st -> st- { current = new- , status = Playing- , cursor = if current == cursor then new else cursor+ { current = new+ , status = Playing+ , cursor = if current == cursor then new else cursor , playHist = Seq.take histSize $ (now, new) <| playHist- , id3 = Nothing+ , id3 = Nothing+ , clock = Nothing } pure f forM_ mfile $ sendMpg . Load@@ -421,14 +398,14 @@ -- | Always pause forcePause :: IO () forcePause = do- st <- getsHS status+ st <- getsHS (.status) when (st == Playing) pause ------------------------------------------------------------------------ -- | Move cursor to currently playing song jumpToPlaying :: IO ()-jumpToPlaying = modifyHS_ $ \st -> st { cursor = current st }+jumpToPlaying = modifyHS_ $ \st -> st { cursor = st.current } -- | Move cursor to first song in next directory (or wrap) jumpToNextDir, jumpToPrevDir :: IO ()@@ -438,49 +415,51 @@ -- | Generic jump to dir jumpToDir :: (Int -> Int -> Int) -> IO () jumpToDir fn = modifyHS_ \st ->- let i = fdir (music st ! cursor st)- d = fn i (length $ folders st)- in st { cursor = dlo (folders st ! d) }+ 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 -> RawFilePath-instance Lookup Dir where extract = takeFileName . dname-instance Lookup File where extract = fbase+class Lookup a where extract :: a -> ByteString+instance Lookup Dir where extract = takeFileName . (.dname)+instance Lookup File where extract = (.fbase) -jumpToMatchFile :: Maybe String -> Bool -> IO ()-jumpToMatchFile re sw = genericJumpToMatch re sw k sel- where k st = (music st, cursor st, size st)- sel i _ = i+setSearchErr :: HState -> ByteString -> HState+setSearchErr st err = st { minibuffer = [plainSeg err] } -jumpToMatchDir :: Maybe String -> Bool -> IO ()-jumpToMatchDir re sw = genericJumpToMatch re sw k sel- where k st = (folders st, fdir (music st ! cursor st), length $ folders st)- sel i st = dlo (folders st ! i)+search :: SearchType -> ByteString -> IO ()+search typ pat = modifyHS_ \st ->+ dispatchSearch (st { searchType = typ }) pat typ -genericJumpToMatch :: Lookup a- => Maybe String- -> Bool- -> (HState -> (Array Int a, Int, Int))- -> (Int -> HState -> Int)- -> IO ()-genericJumpToMatch re sw k sel = do- found <- modifyHS \st -> let- info = case re of- Just s -> Just (st { searchFw = sw }, s, sw)- _ -> listToMaybe [ (st, s, searchFw st == sw) | s <- searchHist st ]- in flip (maybe (st, False)) info \(st', p, forwards) -> do- let (fs, cur, m) = k st- l = if forwards then [cur+1 .. m-1] ++ [0 .. cur]- else [cur-1, cur-2 .. 0] ++ [m-1, m-2 .. cur]- match = matches (P.pack p)- case [ i | i <- l, match $ extract (fs ! i) ] of- i:_ -> (st' { cursor = sel i st }, True)- _ -> (st', False)- unless found $ putMessage $ Fast "No match found." defaultSty+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.@@ -496,16 +475,16 @@ showHist = do now <- getMonoTime setsModal \st -> Just $ HistModal [- (showTimeDiff_ True tm now, (ix, fbase $ music st ! ix))- | (tm, ix) <- toList $ playHist st ]+ (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 (miniFocused st) }+toggleFocus = modifyHS_ $ \st -> st { miniFocused = not st.miniFocused } -- | Toggle the mode flag nextMode :: IO ()-nextMode = modifyHS_ $ \st -> st { mode = next (mode st) } where+nextMode = modifyHS_ $ \st -> st { mode = next st.mode } where next v = if v == maxBound then minBound else succ v ------------------------------------------------------------------------@@ -518,14 +497,14 @@ writeState = do dir <- getStatePath createDirectoryIfMissing True dir- mode <- getsHS mode- writeFile (dir </> "mode") $ show mode ++ "\n"+ mode <- getsHS (.mode)+ writeFile (dir FP.</> "mode") $ show mode ++ "\n" -- | Read mode state readState :: IO Mode readState = do dir <- getStatePath- let f = dir </> "mode"+ let f = dir FP.</> "mode" b <- doesFileExist f modeM <- if b then readMaybe <$!> readFile f@@ -537,11 +516,11 @@ -- getConfPath :: IO FilePath-getConfPath = getXdgDirectory XdgConfig $ "hmp3" </> "style.conf"+getConfPath = getXdgDirectory XdgConfig $ "hmp3" FP.</> "style.conf" loadConfig :: IO () loadConfig = do- f <- maybe getConfPath pure =<< getsHS configPath+ f <- maybe getConfPath pure =<< getsHS (.configPath) b <- doesFileExist f if b then do str' <- readFile f@@ -557,7 +536,7 @@ Just rsty -> do let sty = buildStyle rsty initcolours sty- modifyHS_ $ \st -> st { config = sty }+ modifyHS_ $ \st -> st { uiStyle = sty } else pure () -- TODO in some cases show a warning UI.resetui@@ -565,14 +544,14 @@ ------------------------------------------------------------------------ -- Set the minibuffer -putMessage :: StringA -> IO ()+putMessage :: Line -> IO () putMessage s = modifyHS_ \st -> st { minibuffer = s } clearMessage :: IO ()-clearMessage = putMessage $ Fast P.empty defaultSty+clearMessage = putMessage [] warnA :: String -> IO () warnA x = do- sty <- getsHS config- putMessage $ Fast (P.pack x) (warnings sty)+ sty <- getsHS (.uiStyle.warnings)+ putMessage [Seg sty (P.pack x)]
Decoder.hs view
@@ -5,66 +5,55 @@ -- Wire protocol for mpg123 module Decoder (- mpgParser, Cmd(..), cmdToBS,+ mp3Tool, mpgParser, Cmd(..), cmdToBS, Msg(..), Id3(..), Status(..), Frame(..), ) where import Base+import Text (trim, readIntM, showInt, guessEncoding) import Data.ByteString.Char8 qualified as P-import Data.ByteString.UTF8 qualified as UTF8 ++mp3Tool :: IsString a => a+mp3Tool = "mpg123"+ ------------------------------------------------------------------------ -- Send commands to mpg123 -data Cmd = Load ByteString | Jump Int | Pause | Quit+data Cmd = Load !ByteString | Jump !(Fixed E2) | Pause | Quit cmdToBS :: Cmd -> ByteString cmdToBS (Load f) = "L " <> f-cmdToBS (Jump i) = "J " <> P.pack (show i) -- can be relative with +/-; not used here+cmdToBS (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 {-# UNPACK #-} !ByteString- | F {-# UNPACK #-} !Frame- | P !Status+data Msg = I !Id3 | S !ByteString | F !Frame | P !Status deriving stock (Eq, Show) -- ID3 info data Id3 = Id3- { id3title :: !ByteString- , id3artist :: !ByteString- , id3album :: !ByteString- , id3str :: !ByteString+ { 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-frame and frames-remaining are integers; current-time and--- time-remaining floating point numbers with two decimal places.-data Frame = Frame {- currentFrame :: !Int,- framesLeft :: !Int,- currentTime :: !(Fixed E2),- timeLeft :: !(Fixed E2)- } deriving stock (Eq, Show)+-- 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) --- | Strip leading and trailing whitespace.-trim :: ByteString -> ByteString-trim = P.dropWhileEnd isSpace . P.dropSpace--readPS :: ByteString -> Maybe Int-readPS = fmap fst . P.readInt- doP :: ByteString -> Maybe Msg doP s = do (p, _) <- P.uncons s@@ -77,12 +66,10 @@ -- Frame decoding status updates (once per frame). doF :: ByteString -> Maybe Msg doF s = do- f0 : f1 : f2 : f3 : _ <- pure $ P.split ' ' s- currentFrame <- readPS f0- framesLeft <- readPS f1- currentTime <- readMaybe $ P.unpack f2- timeLeft <- max 0 <$> readMaybe (P.unpack f3)- pure $ F Frame { currentFrame, framesLeft, currentTime, timeLeft }+ _ : _ : 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):@@ -102,17 +89,16 @@ doS s = do let fs = P.split ' ' s guard $ length fs >= 11- hz <- readPS $ fs !! 2+ hz <- readIntM $ fs !! 2 pure $ S $ mconcat [- "mpeg ", fs !! 0, " ", fs !! 10, "kb/s ",- P.pack $ show $ hz `div` 1000, "kHz"]+ "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 $ id3title id3 -- title sometimes empty+ guard $ not $ P.null $ id3.title -- title sometimes empty pure id3 -- Format: title (30), author (30), album (30), year (4), comment (30), genre@@ -120,18 +106,11 @@ parseId3 :: ByteString -> Id3 parseId3 = toId . cut where cut f | P.null f = []- | True = let (a, xs) = P.splitAt 30 f in normalise a : cut xs+ | 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 !?)---- | Strip spaces, and if seeming ISO-8859-1 convert to UTF-8-normalise :: ByteString -> ByteString-normalise raw =- let bs = trim raw- in if UTF8.replacement_char `elem` UTF8.toString bs- then UTF8.fromString $ P.unpack bs- else bs -- Parse line; on failure, return Just only if error to report. mpgParser :: ByteString -> Either (Maybe String) Msg
+ Elements.hs view
@@ -0,0 +1,149 @@+-- 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) ' '+
Keymap.hs view
@@ -10,20 +10,24 @@ -- transitions (entering search, popping up the song-history modal, -- confirming a quit) are just "return a different 'KeyMap'." ---module Keymap (keyLoop, keyTable, unkey, charToKey) where+module Keymap (keyLoop, keyTable, unkey, charToKey, dropLastUTF8) where import Base import Core-import Config (package)+import Elements (package) import Keyboard (unkey, charToKey, Key(..), historyKeys)-import State (getsHS, modifyHS_, KeysHelp, Modal(..), HState(..))-import Style (defaultSty, StringA(Fast))+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) ------------------------------------------------------------------------@@ -45,7 +49,7 @@ -- Top-level normal mode mainMode :: KeyMap-mainMode = KeyMap \c -> getsHS modal >>= \case+mainMode = KeyMap \c -> getsHS (.modal) >>= \case Just ExitModal | c `elem` ['y', 'Y', '\^C'] -> shutdown Nothing $> undefined@@ -58,30 +62,32 @@ _ -> if | c `elem` ['/', '?', '\\', '|'] -> do toggleFocus- hist <- getsHS searchHist+ hist <- getsHS (.searchHist) searchMode c $ Zipper "" hist []- | c `elem` ['q', '\^C'] ->- forcePause *> setsModal (const $ Just ExitModal) $> mainMode- | c `elem` ['H', ';'] ->- showHist $> mainMode | 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 --- | Zipper over the search-history list, with the currently edited--- string in the focus. 'back' holds older entries we can step back--- to (Up); 'front' holds entries we've stepped back from (Down).-data Zipper = Zipper { cur :: !String, _back :: ![String], _front :: ![String] }--searchMode :: Char -> Zipper -> IO KeyMap+searchMode :: Char -> Zipper ByteString -> IO KeyMap searchMode stype = step where step z = renderSearch stype z $> KeyMap (`dispatch` z) @@ -89,47 +95,32 @@ | c `elem` ['\ESC', '\^C'] = clearMessage *> leave | c `elem` enter' = commit z- | c `elem` delete' = step $ zipEdit dropLast 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 (++ [c]) z+ | otherwise = step $ zipEdit (`P.snoc` c) z where k = charToKey c - commit (Zipper [] _ _) = clearMessage *> leave+ commit (Zipper "" _ _) = clearMessage *> leave commit (Zipper pat _ _) = do- let jumpy = if stype `elem` ['/', '?']- then jumpToMatchFile else jumpToMatchDir- jumpy (Just pat) (stype `elem` ['/', '\\'])- modifyHS_ \st -> st { searchHist = pat : filter (/= pat) (searchHist st) }+ 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 (/= cur z) (searchHist st) }+ modifyHS_ \st -> st { searchHist = filter (/= z.cur) st.searchHist } step z' leave = toggleFocus $> mainMode -renderSearch :: Char -> Zipper -> IO ()-renderSearch prefix z = putMessage $ Fast (P.pack (prefix : cur z)) defaultSty--dropLast :: [a] -> [a]-dropLast [] = []-dropLast xs = init xs--zipEdit :: (String -> String) -> Zipper -> Zipper-zipEdit f z = z { cur = f (cur z) }--zipUp, zipDown :: Zipper -> Zipper-zipUp (Zipper c (nx:rest) f) = Zipper nx rest (c:f)-zipUp z = z-zipDown (Zipper c b (pv:rest)) = Zipper pv (c:b) rest-zipDown z = z+renderSearch :: Char -> Zipper ByteString -> IO ()+renderSearch prefix z = putMessage [plainSeg $ prefix `P.cons` z.cur] enter', delete' :: [Char] enter' = ['\n', '\r']@@ -148,41 +139,55 @@ , ("Jump to start of list", [unkey KeyHome,'0'], jump 0) , ("Jump to end of list", [unkey KeyEnd,'G'], jump maxBound) , ("Jump to 10%, 20%, 30%, etc., point", ['1','2','3'], placeholder)- , ("Seek left within song", [unkey KeyLeft], seekLeft)- , ("Seek right within song", [unkey KeyRight], seekRight)+ , ("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'], jumpToMatchFile Nothing True)- , ("Repeat last regex search backwards", ['N'], jumpToMatchFile Nothing False)- , ("Play", ['p'], playCur)+ , ("Repeat last regex search", ['n'], repeatSearch True)+ , ("Repeat last regex search backwards", ['N'], repeatSearch False) , ("Mark for deletion in .hmp3-delete", ['D'], blacklist)- , ("Load config file", ['l'], loadConfig) , ("Restart song", [unkey KeyBackspace], seekStart)- , ("Toggle the song history", ['H', ';'], placeholder)+ , ("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)- , ("Quit " <> UTF8.fromString package, ['q'], 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 ]+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 $ modal st then Just $ HelpModal keysHelp else Nothing+ if isNothing st.modal then Just $ HelpModal keysHelp else Nothing
State.hs view
@@ -9,14 +9,15 @@ import Base -import Decoder (Status, Frame, Id3, Cmd, cmdToBS)+import Decoder (Status, Frame, Id3, Cmd, cmdToBS, mp3Tool) import Playlist (FileArray, DirArray)-import Style (StringA, UIStyle)+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)+import System.Process (ProcessHandle, waitForProcess) import System.Random (StdGen) @@ -25,36 +26,37 @@ -- These never change { music :: !FileArray , folders :: !DirArray- , size :: !Int -- cache size of list , 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- , mpgPid :: !(Maybe ProcessHandle) -- pid of decoder , spawns :: !Integer -- count of decoder spawns- , threads :: ![ThreadId] -- all our threads , id3 :: !(Maybe Id3) -- maybe mp3 id3 info , info :: !(Maybe ByteString) -- mp3 info , status :: !Status- , minibuffer :: !StringA -- contents of minibuffer+ , 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- , searchFw :: !Bool -- active search direction- , searchHist :: ![String]- , exiting :: !Bool -- let mpg123 die?+ , searchType :: !SearchType+ , searchHist :: ![ByteString] , playHist :: !(Seq (TimeSpec, Int))- , histSize :: Int- , config :: !UIStyle+ , 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))] @@ -80,18 +82,47 @@ ------------------------------------------------------------------------ -- The decoder. -data Mpg = Mpg { errh :: !Handle, writeh :: !Handle }+-- | Decoder read handle (mpg123 stderr).+mpgRead :: MVar Handle+mpgRead = unsafePerformIO newEmptyMVar+{-# NOINLINE mpgRead #-} -mpg :: MVar Mpg-mpg = unsafePerformIO newEmptyMVar-{-# NOINLINE mpg #-}+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 = withMVar mpg $ (. writeh) \h ->- hPut h (cmdToBS c) *> hPut h "\n" *> hFlush h+sendMpg c = do+ ok <- sendMpg' c+ when (not ok) $ modifyHS_ \st -> st { minibuffer =+ [Seg st.uiStyle.warnings (mp3Tool <> " process not running")] } --------------------------------------------------------------------------- state accessor functions+-- State accessor functions. -- | Access a component of the state with a projection function getsHS :: (HState -> a) -> IO a
Style.hs view
@@ -2,9 +2,7 @@ -- Copyright (c) 2019-2022, 2026 Galen Huntington -- SPDX-License-Identifier: GPL-2.0-or-later --- -- | Color manipulation--- module Style where @@ -47,18 +45,16 @@ data Style = Style !Color !Color deriving stock (Eq,Ord) --- | A list of styled UTF-8 ByteString segments making up one line.--- 'Fast' is the single-segment fast path; 'FancyS' is a multi-segment line.-data StringA- = Fast {-# UNPACK #-} !ByteString {-# UNPACK #-} !Style- | FancyS ![(ByteString, Style)]+-- | 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@@ -82,44 +78,33 @@ _ -> 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-{-# INLINE setAttribute #-} --- -- | Reset the screen to normal values--- reset :: IO () reset = setAttribute (Curses.attr0, Curses.Pair 0)-{-# INLINE reset #-} --- -- | And turn on the colours--- initcolours :: UIStyle -> IO () initcolours sty = do- let ls = [modals sty, warnings sty, window sty,- selected sty, titlebar sty, progress sty,- blockcursor sty, cursors sty, combined sty ]- (Style fg bg) = progress sty -- bonus style+ 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 (window sty) >>= \(_,p) -> Curses.bkgrndSet nullA p+ 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,@@ -138,24 +123,20 @@ 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-{-# INLINE uiAttr #-} -- | 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)-{-# INLINE lookupPair #-} -- | Keep a map of nice style defs to underlying curses pairs, created at init time type PairMap = M.Map Style (Curses.Attr, Curses.Pair)@@ -166,22 +147,17 @@ {-# 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@@ -194,7 +170,6 @@ -- | Map an abstract 'Style' to its ncurses foreground/background pair. style2curses :: Style -> (CColor, CColor) style2curses (Style fg bg) = (fgCursCol fg, bgCursCol bg)-{-# INLINE style2curses #-} -- | The ncurses color for each ANSI hue. hueColor :: Hue -> Curses.Color@@ -222,8 +197,10 @@ 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@@ -244,23 +221,48 @@ , 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 $ hmp3_window bs- , modals = f $ hmp3_modals bs- , titlebar = f $ hmp3_titlebar bs- , selected = f $ hmp3_selected bs- , cursors = f $ hmp3_cursors bs- , combined = f $ hmp3_combined bs- , warnings = f $ hmp3_warnings bs- , blockcursor = f $ hmp3_blockcursor bs- , progress = f $ hmp3_progress bs+ 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 view
@@ -0,0 +1,89 @@+-- 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 view
@@ -5,29 +5,27 @@ -- 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+ getKey,+ -- * Tool+ u, ) where import Base-+import Elements as El import Style import Playlist (File(fdir, fbase), Dir(dname)) import State import Decoder-import Config-import Width (displayWidth, toMaxWidth, toWidth)+import Text (u, displayWidth, toMaxWidth, toWidth, spaces, showInt) import UI.HSCurses.Curses qualified as Curses-import Keyboard (unkey, charToKey, historyKeys)+import Keyboard (unkey) import Data.Array ((!), bounds, Array) import Data.Array.Base (unsafeAt)@@ -41,14 +39,8 @@ import Data.ByteString.Char8 qualified as P import Data.ByteString.Unsafe qualified as P-import Data.ByteString.UTF8 qualified as UTF8 --- Write u-strings like it's Python 2.-u :: String -> ByteString-u = UTF8.fromString-- newtype Draw = Draw (IO ()) deriving newtype (Semigroup, Monoid) @@ -71,7 +63,7 @@ _ -> pure () -- handled elsewhere colorify <- Curses.hasColors- let sty = if colorify then defaultStyle else bwStyle+ let sty = if colorify then defaultStyle else monoStyle initcolours sty Curses.keypad Curses.stdScr True -- grab the keyboard@@ -98,10 +90,8 @@ 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@@ -113,10 +103,8 @@ 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@@ -129,9 +117,8 @@ -- | Resize the window -- From "Writing Programs with NCURSES", by Eric S. Raymond and Zeyd M. Ben-Halim--- resizeui :: Draw-resizeui = Draw $ void $ do+resizeui = Draw do Curses.endWin Curses.resetParams do@@ -143,7 +130,7 @@ -- Curses.meta stdScr True -- not in module -- not sure about intrFlush, raw - set in hscurses Curses.refresh- Curses.scrSize+ void Curses.scrSize refresh :: IO () refresh = runDraw $ redraw <> Draw Curses.refresh@@ -153,35 +140,16 @@ ------------------------------------------------------------------------ --- (prefix some with underscore to avoid unused warnings)-data Pos = Pos { posY, _posX :: !Int }-data Size = Size { _sizeH, sizeW :: !Int }---- | Renderable widgets are functions @DrawData -> ...@.-data DrawData = DD {- drawSize :: Size,- drawPos :: Pos,- drawState :: HState,- drawFrame :: Maybe Frame- }---- screen width -> (modal width, list of lines)-type ModalMaker = Int -> (Int, [ByteString])------------------------------------------------------------------------------ | The three lines of the play info widget.-playScreen :: DrawData -> [StringA]-playScreen dd = [pPlaying dd, progressBar dd, pTimes dd]+data DrawData = DD { drawWidth :: !Int, drawState :: !HState } ------------------------------------------------------------------------ -- | Info about the current track-pPlaying :: DrawData -> StringA-pPlaying dd = flip Fast defaultSty $ " " <> mconcat line where- x = sizeW $ drawSize dd+pPlaying :: DrawData -> Line+pPlaying dd = pure $ plainSeg $ " " <> mconcat line where+ x = dd.drawWidth a = pId3 dd- b = pInfo 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)@@ -191,215 +159,89 @@ -- | Id3 info pId3 :: DrawData -> ByteString-pId3 DD{drawState=st} = case id3 st of- Just i -> id3str i- Nothing -> fbase $ music st ! current st---- | mp3 information-pInfo :: DrawData -> ByteString-pInfo DD{drawState=st} = fromMaybe "" $ info st--commonModalWidth :: Int -> Int-commonModalWidth w = max (min w 3) $ round $ fromIntegral w * (0.8::Float)----------------------------------------------------------------------------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) ' '+pId3 DD{drawState=st} = maybe (st.music ! st.current).fbase (.str) st.id3 ------------------------------------------------------------------------ -showClock :: Fixed E2 -> ByteString-showClock t =- let m, si, sd :: Int- (m, s) = t `divMod'` 60- si = floor s- sd = floor (s*10) `mod` 10- in P.pack $ printf "%d:%02d.%d" m si sd---- | The time used and time left-pTimes :: DrawData -> StringA-pTimes DD { drawFrame=Just Frame {..}, drawSize=Size{sizeW=w} } =- flip Fast defaultSty $ if w - 4 < P.length elapsed- then ""- else mconcat $ [" ", elapsed] ++ [gap <> "-" <> remaining | distance > 0]+-- | Show progress bar.+progressBar :: DrawData -> Line+progressBar (DD w st) = [+ plainSeg " ", Seg (Style fg fg) (spaces x), Seg sty (spaces (w'-x)) ] where- elapsed = showClock currentTime- remaining = showClock timeLeft- gap = spaces distance- distance = w - 5 - P.length elapsed - P.length remaining-pTimes _ = Fast "" defaultSty--------------------------------------------------------------------------+ w' = w - 4+ x = El.progress w' st.clock+ sty@(Style fg _) = st.uiStyle.progress --- | A progress bar-progressBar :: DrawData -> StringA-progressBar dd@DD{drawSize=Size{sizeW=w}, drawState=st} = case drawFrame dd of- Nothing -> FancyS [(" ", defaultSty), (spaces (w-4), bgs)]- where- Style _ bg = progress (config st)- bgs = Style bg bg- Just Frame {..} -> FancyS- [ (" ", defaultSty)- , (spaces distance, fgs)- , (spaces (width - distance), bgs) ]- where- width = w - 4- total = curr + left- distance = round ((curr / total) * fromIntegral width)- curr = realToFrac currentTime :: Float- left = realToFrac timeLeft- Style fg bg = progress (config st)- bgs = Style bg bg- fgs = Style fg fg+-- | Two lines showing clock.+clockLines :: DrawData -> [Line]+clockLines dd@(DD w st) = [progressBar dd, [plainSeg (El.pTimes w st.clock)]] ------------------------------------------------------------------------ --- | Version info-pVersion :: ByteString-pVersion = P.pack versinfo---- | Uptime-pTime :: DrawData -> ByteString-pTime = uptime . drawState- -- | Play state pState :: DrawData -> String-pState dd = case status (drawState dd) of+pState dd = case dd.drawState.status of Stopped -> "◼" Paused -> "⏸" Playing -> "▶" -- | Play mode pMode :: DrawData -> String-pMode dd = take 4 $ map toLower $ show $ mode $ drawState dd+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 = mconcat+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- st = drawState dd- tobs = P.pack . show- curf = tobs $ 1 + cursor st- numf = tobs $ size st- mydir = fdir $ music st ! cursor st- curd = tobs $ 1 + mydir- numd = tobs $ length $ folders st+ 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 -> StringA-playTitle dd =- flip Fast hl $ mconcat if gap >= 2- then [" ", inf, spaces gapl, indic, spaces gapr, time, " ", ver, " "]- else let gap' = x - indicl; gapl' = gap' `div` 2- in if gap' >= 2- then [spaces gapl', indic, spaces $ gap' - gapl']- else [" ", P.take (x-2) indic, " "]+playTitle :: DrawData -> Line+playTitle dd@DD{drawWidth=w, drawState=st} =+ [Seg st.uiStyle.titlebar $ El.layoutLCR w (left, centerS, right)] where- inf = playInfo dd- time = pTime dd- indic = u $ pState dd ++ ' ' : pMode dd- ver = pVersion+ left = " " <> playInfo dd+ centerS = pState dd ++ ' ' : pMode dd -- always 6 chars+ right = st.uptime <> " " <> El.pVersion <> " " - x = sizeW $ drawSize dd- lsize = 1 + P.length inf- rsize = 2 + P.length time + P.length ver- side = (x - indicl) `div` 2- gap = x - indicl - lsize - rsize- gapl = 1 `max` ((side - lsize) `min` (gap - 1))- gapr = gap - gapl- indicl = 6 -- length indic- hl = titlebar . config $ drawState dd+-- | 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) [] --- | The scrolling playlist (title + visible tracks + minibuffer).-playList :: DrawData -> [StringA]-playList dd@DD{ drawSize=Size y x, drawPos=Pos{posY=o}, drawState=st } =- playTitle dd- : list- ++ replicate (height - length list - 2) (Fast P.empty defaultSty)- ++ [minibuffer st] where- songs = music st- this = current st- curr = cursor st- height = y - o- -- number of screens down, and then offset- buflen = height - 2- (screens, select) = quotRem curr buflen -- keep cursor in screen-- playing = let top = screens * buflen- bot = (screens + 1) * buflen- in if this >= top && this < bot- then this - top -- playing song is visible- else (-1)+ (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) songs+ 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 fdir v > n then Just (fdir v) else Nothing- in (r, toMaxWidth (x - indent - 1) $ fbase v)- : loop (fdir 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 $ (0.334 :: Float) * fromIntegral x) :: Int+ indent = round $ st.folderCol * fromIntegral (w - 1) :: Int - (sty1, sty2, sty3) = (selected cs, cursors cs, combined cs)- where cs = config st+ (sty1, sty2, sty3) = (cs.selected, cs.cursors, cs.combined)+ where cs = st.uiStyle color :: ((Maybe Int, ByteString), Int) -> (Maybe Int, (Style, [ByteString]))@@ -409,140 +251,98 @@ (_ , True) -> f sty1 _ -> (defaultSty, [s]) where- f sty = (sty, [s, spaces (x - indent - 1 - displayWidth s)])+ f sty = (sty, [s, spaces (w - indent - 1 - displayWidth s)]) - drawIt :: (Maybe Int, (Style, [ByteString])) -> StringA+ drawIt :: (Maybe Int, (Style, [ByteString])) -> Line drawIt (Nothing, (sty, v)) =- FancyS $ map (, sty) $ spaces (1 + indent) : v- drawIt (Just i, (sty, v)) = FancyS- $ (d, sty')- : (spaces (indent + 1 - displayWidth d), sty')- : map (, 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 $ dname $ folders st ! i----------------------------------------------------------------------------spaces :: Int -> ByteString-spaces = flip P.replicate ' '+ d = toMaxWidth (indent - 1) $ takeFileName (st.folders ! i).dname --------------------------------------------------------------------------- | Now write out just the clock line+-- | Write out only the clock lines. redrawJustClock :: Draw redrawJustClock = Draw $ discardErrors do- st <- getsHS id+ st <- getsHS id (h, w) <- screenSize- let dd = DD (Size h w) undefined st (clock st)- Curses.wMove Curses.stdScr 1 0 -- hardcoded!- drawLine $ progressBar dd- Curses.wMove Curses.stdScr 2 0 -- hardcoded!- drawLine $ pTimes dd+ drawFullLines (h-1) 1 $ clockLines $ DD w st ------------------------------------------------------------------------ -- | General modal renderer.-renderModal :: HState -> Size -> ModalMaker -> IO ()-renderModal st (Size h w) mkr = do+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- sty = modals $ config st- Curses.wMove Curses.stdScr voffset hoffset- for_ (take vislines modal') \t -> do- drawLine $ Fast (toWidth mw t) sty- (y', _) <- Curses.getYX Curses.stdScr- Curses.wMove Curses.stdScr (y'+1) hoffset+ 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 -> Size -> IO ()+renderModals :: HState -> (Int, Int) -> IO () renderModals st sz =- whenJust (modal st) $ renderModal st sz . \case- HelpModal h -> helpModal h- HistModal h -> histModal h- ExitModal -> exitModal+ 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 {- TODO what errors are discarded? -} do- st <- getsHS id -- another refresh could be triggered?- (h, w) <- screenSize- let sz = Size h w- screen = playScreen (DD sz (Pos 0 0) st (clock st))- a = screen ++ playList (DD sz (Pos (length screen) 0) st (clock st))-+redraw = Draw $ discardErrors do+ st <- getsHS id+ sz@(h, w) <- screenSize setXterm st-- gotoTop- for_ (take (h-1) (init a)) \t -> do- drawLine t- (y, x) <- Curses.getYX Curses.stdScr- fillLine- maybeLineDown t h y x+ 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- Curses.wMove Curses.stdScr (h-1) 0- drawLine (last a)- when (miniFocused st) do -- a fake cursor- drawLine (Fast (spaces 1) (blockcursor . config $ st ))- -- XXX is this TODO from 2005 still relevant?- -- todo rendering bug here when deleting backwards in minibuffer +-- | 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 :: StringA -> IO ()-drawLine (Fast ps sty) = drawSegment ps sty-drawLine (FancyS ls) = traverse_ (uncurry drawSegment) ls+drawLine :: Line -> IO ()+drawLine = traverse_ drawSegment -- | Write a single styled UTF-8 segment. Safe because C only reads the bytes.-drawSegment :: ByteString -> Style -> IO ()-drawSegment bs sty = withStyle sty $ void $+drawSegment :: Segment -> IO ()+drawSegment (Seg sty bs) = withStyle sty $ void $ P.unsafeUseAsCStringLen bs \(cstr, len) -> waddnstr Curses.stdScr cstr (fromIntegral len) - ------------------------------------------------------------------------ -maybeLineDown :: StringA -> Int -> Int -> Int -> IO ()-maybeLineDown (Fast s _) h y _ | s == P.empty = lineDown h y-maybeLineDown _ h y x- | x == 0 = pure () -- already moved down- | otherwise = lineDown h y----------------------------------------------------------------------------lineDown :: Int -> Int -> IO ()-lineDown h y = Curses.wMove Curses.stdScr (min h (y+1)) 0---- -- | Fill to end of line spaces---+-- (Curses throws error if already at end.) fillLine :: IO ()-fillLine = discardErrors Curses.clrToEol -- harmless?------- | move cursor to origin of stdScr.----gotoTop :: IO ()-gotoTop = Curses.wMove Curses.stdScr 0 0-{-# INLINE gotoTop #-}+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] ]-{-# INLINE slice #-}+ 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])@@ -555,13 +355,11 @@ -- set xterm title. Don't need to do this on each refresh... setXterm :: HState -> IO ()-setXterm s = setXtermTitle $ case status s of- Playing -> case id3 s of- Nothing -> [fbase $ music s ! current s]- Just ti -> id3artist ti :- if P.null (id3title ti)- then []- else [": ", id3title ti]+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"]
− Width.hs
@@ -1,45 +0,0 @@--- Copyright (c) 2019-2026 Galen Huntington--- SPDX-License-Identifier: GPL-2.0-or-later---- | Width-aware operations on UTF-8 'ByteString's, using libc 'wcwidth'.--- A UTF-8 runtime locale is presumed; counts may differ otherwise.-module Width (displayWidth, toMaxWidth, toWidth) where--import Base--import Data.ByteString.Char8 qualified as P-import Data.ByteString.UTF8 qualified as UTF8--import Foreign.C.Types----- | Sum of the column widths of every codepoint in a UTF-8 'ByteString'.-displayWidth :: ByteString -> Int-displayWidth = UTF8.foldl (\acc c -> acc + charWidth c) 0---- | These functions truncate with ellipses if needed to get width ≤'w'.--- 'toWidth' adds padding as needed so the width is exactly 'w'.-toMaxWidth, toWidth :: Int -> ByteString -> ByteString-toMaxWidth = sizer False-toWidth = sizer True--sizer :: Bool -> Int -> ByteString -> ByteString-sizer pad w bs- | dw <= w = if pad then bs <> P.replicate (w-dw) ' ' else bs- | True = walk 0 bs- where- dw = displayWidth bs- walk !l rest- | l' >= w = P.take (P.length bs - P.length rest) bs- <> mconcat (replicate (w-l) $ UTF8.fromString "…")- | True = walk l' rest'- where- (c, rest') = fromJust $ UTF8.uncons rest -- can't be at end since dw>w- l' = l + charWidth c--charWidth :: Char -> Int-charWidth = fromIntegral . wcwidth . toEnum . fromEnum--foreign import ccall safe- wcwidth :: CWchar -> CInt-
app/Main.hs view
@@ -8,7 +8,7 @@ import Base import Core (start, shutdown, Options(..))-import Config qualified+import Elements (fullVersion) import Keymap (keyLoop) import Playlist (buildPlaylist, isEmpty) @@ -60,15 +60,16 @@ <*> option auto ( 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...") parserInfo :: ParserInfo (Options, [ByteString]) parserInfo = info (invocation <**> versionOpt <**> helper) $ fullDesc- <> header Config.versinfo+ <> header fullVersion <> progDesc "Play mp3 files in a curses interface." where- versionOpt = infoOption Config.versinfo+ versionOpt = infoOption fullVersion (hidden <> long "version" <> short 'V' <> help "Show version information") -- XXX should this have tests?
hmp3-ng.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hmp3-ng-version: 2.19.0+version: 2.19.1 synopsis: A 2019 fork of an ncurses mp3 player written in Haskell description: An mp3 player with a curses frontend. Playlists are populated by@@ -15,7 +15,6 @@ license: GPL-2.0-or-later license-file: LICENSE build-type: Simple- extra-doc-files: README.md @@ -28,32 +27,34 @@ default-extensions: BlockArguments MultiWayIf+ NoFieldSelectors+ OverloadedRecordDot OverloadedStrings RecordWildCards -- In GHC2024+ DataKinds DerivingStrategies LambdaCase ghc-options: -Wall -Wprepositive-qualified-module- -funbox-strict-fields library import: opts hs-source-dirs: ./ exposed-modules: Base- Config Core Decoder+ Elements Keyboard Keymap Playlist State Style+ Text UI- Width other-modules: Paths_hmp3_ng@@ -78,6 +79,7 @@ process, random, regex-posix,+ transformers, unix >=2.8, utf8-string, @@ -99,13 +101,11 @@ main-is: Main.hs hs-source-dirs: test other-modules:- BaseSpec- ConfigSpec- CoreSpec DecoderSpec+ ElementsSpec PlaylistSpec StyleSpec- WidthSpec+ TextSpec build-depends: base,
− test/BaseSpec.hs
@@ -1,30 +0,0 @@-module BaseSpec (tests) where--import Data.ByteString.UTF8 qualified as UTF8--import Test.Tasty-import Test.Tasty.HUnit--import Base (matches)--tests :: TestTree-tests = testGroup "Base"- [ testGroup "match"- [ t True "exact" "foo" "fooBar"- , t True "caseless" "FOO" "fooBar"- , t False "invalid" "[" "any[thing"- , t True "alt" "(foo|az)Q" "bazQux"- , t True "dot" "o.a" "foobar"- , t True "Unicode" "jör" "Björk"- , t True "dot Unicode" "j.r" "Björk"- , t True "Nordic case" "bør" "BØrnE"- , t True "Greek case" "Λω" "ΦλΩα"- , t True "dot CJK" "中.人" "中國人"- ]- ]---t :: Bool -> String -> String -> String -> TestTree-t b tag pat str =- testCase tag $ matches (UTF8.fromString pat) (UTF8.fromString str) @?= b-
− test/ConfigSpec.hs
@@ -1,35 +0,0 @@-module ConfigSpec (tests) where--import Control.Exception-import Data.Either (isRight)--import Test.Tasty-import Test.Tasty.HUnit--import Config (fixedStyles, defaultStyle)-import Style (UIStyle(..), style)--tests :: TestTree-tests = testGroup "Config"- [ testGroup "styles"- [ testStyles "built-in styles valid" fixedStyles True- , testStyles "wrong style invalid" badStyles False- ]- ]---- Check WHNF evaluation doesn't throw.--- Suffices because UIStyle is recursively strict.-evalOk :: a -> IO Bool-evalOk = fmap isRight . try @SomeException . evaluate--testStyles :: Traversable t => String -> t UIStyle -> Bool -> TestTree-testStyles s m b = testCase s $ (@?= b) . and =<< traverse evalOk m---- Test that test actually tests.-badStyles :: [UIStyle]-badStyles =- [ defaultStyle- , defaultStyle { window = style "badcolor" "default" }- , defaultStyle- ]-
− test/CoreSpec.hs
@@ -1,44 +0,0 @@-module CoreSpec (tests) where--import Test.Tasty-import Test.Tasty.HUnit--import System.Clock (TimeSpec(..))--import Core (showTimeDiff_)--tests :: TestTree-tests = testGroup "Core"- [ testGroup "showTimeDiff_ (secs=False)"- [ testCase "under a minute is 0m"- $ showTimeDiff_ False (t 0) (t 30) @?= "0m"- , testCase "exactly one minute"- $ showTimeDiff_ False (t 0) (t 60) @?= "1m"- , testCase "under an hour"- $ showTimeDiff_ False (t 0) (t 599) @?= "9m"- , testCase "exactly one hour"- $ showTimeDiff_ False (t 0) (t 3600) @?= "1h00m"- , testCase "one hour, one minute, one second drops seconds"- $ showTimeDiff_ False (t 0) (t 3661) @?= "1h01m"- , testCase "exactly one day"- $ showTimeDiff_ False (t 0) (t 86400) @?= "1d00h00m"- , testCase "day, hour, minute"- $ showTimeDiff_ False (t 0) (t 90060) @?= "1d01h01m"- ]- , testGroup "showTimeDiff_ (secs=True)"- [ testCase "thirty seconds"- $ showTimeDiff_ True (t 0) (t 30) @?= "30s"- , testCase "one minute exactly appends 00s"- $ showTimeDiff_ True (t 0) (t 60) @?= "1m00s"- , testCase "one minute thirty seconds"- $ showTimeDiff_ True (t 0) (t 90) @?= "1m30s"- , testCase "one hour one minute one second"- $ showTimeDiff_ True (t 0) (t 3661) @?= "1h01m01s"- , testCase "diff is taken from monotonic delta, not absolute values"- $ showTimeDiff_ True (t 1000) (t 1090) @?= "1m30s"- ]- ]---- Build a TimeSpec from a whole number of seconds.-t :: Integer -> TimeSpec-t s = TimeSpec (fromInteger s) 0
test/DecoderSpec.hs view
@@ -5,9 +5,10 @@ import Data.ByteString.Char8 qualified as P +import Base import Decoder --- These exercise the helpers doX, 'trim', and 'normalise'.+-- These exercise the helpers doX and 'trim' tests :: TestTree tests = testGroup "Lexer.mpgParser" [ testGroup "status (@P)"@@ -19,8 +20,8 @@ , tc "@P " $ Left Nothing -- no payload ] , testGroup "frame (@F)"- [ tc "@F 123 456 12.34 56.78" $ Right (F (Frame 123 456 12.34 56.78))- , tc "@F 0 0 0.00 -1.00" $ Right (F (Frame 0 0 0.00 0)) -- timeLeft clamped+ [ tc "@F 123 456 12.34 56.78" $ Right (F (Frame 12.34 56.78))+ , tc "@F 0 0 0.00 -1.00" $ Right (F (Frame 0.00 0)) -- .left clamped , tc "@F 1 2 3.00" $ Left Nothing -- too few fields , tc "@F a b c d" $ Left Nothing -- non-numeric ]@@ -29,7 +30,7 @@ $ Right (S "mpeg 1.0 128kb/s 44kHz") , tc "@S 1.0 1 44100" $ Left Nothing -- too few fields ]- , testGroup "id3 (@I)" (let s = "n\195\182rmalise" in+ , testGroup "id3 (@I)" [ tcId3 ["Title"] $ Right (I (Id3 "Title" "" "" "Title")) , tcId3 ["Title", "Artist"]@@ -41,9 +42,7 @@ , tcId3 ["", "Artist"] $ Left Nothing -- blank title: skipped , tc "@I song.mp3" $ Left Nothing -- non-ID3 @I: don't overwrite , tc "@I {" $ Left Nothing -- grouping marker: ignored- , tcId3 ["nörmalise"] $ Right (I (Id3 s "" "" s))- , tcId3 [s] $ Right (I (Id3 s "" "" s))- ])+ ] , testGroup "tagline, errors, junk" [ tc "@E some failure" $ Left (Just "some failure") , tc "garbage" $ Left Nothing -- no @ prefix@@ -58,6 +57,6 @@ tcId3 fields = tc' (show fields) (id3 fields) -- | Build an "@I ID3:" line from fixed-width 30-char fields, as mpg123 emits.-id3 :: [P.ByteString] -> P.ByteString+id3 :: [ByteString] -> ByteString id3 fields = "@I ID3:" <> mconcat [ P.take 30 (f <> P.replicate 30 ' ') | f <- fields ]
+ test/ElementsSpec.hs view
@@ -0,0 +1,74 @@+module ElementsSpec (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import Data.ByteString.Char8 qualified as P+import System.Clock (TimeSpec(..))++import Base+import Text (displayWidth)+import Elements (showDuration, fitLCR, layoutLCR, Fit(..))++tests :: TestTree+tests = testGroup "Elements"+ [ testGroup "showDuration (showSecs=False)"+ [ testCase "under a minute is 0m"+ $ showDuration False (t 30) @?= "0m"+ , testCase "exactly one minute"+ $ showDuration False (t 60) @?= "1m"+ , testCase "under an hour"+ $ showDuration False (t 599) @?= "9m"+ , testCase "exactly one hour"+ $ showDuration False (t 3600) @?= "1h00m"+ , testCase "one hour, one minute, one second drops seconds"+ $ showDuration False (t 3661) @?= "1h01m"+ , testCase "exactly one day"+ $ showDuration False (t 86400) @?= "1d00h00m"+ , testCase "day, hour, minute"+ $ showDuration False (t 90060) @?= "1d01h01m"+ ]+ , testGroup "showDuration (showSecs=True)"+ [ testCase "thirty seconds"+ $ showDuration True (t 30) @?= "30s"+ , testCase "one minute exactly appends 00s"+ $ showDuration True (t 60) @?= "1m00s"+ , testCase "one minute thirty seconds"+ $ showDuration True (t 90) @?= "1m30s"+ , testCase "one hour one minute one second"+ $ showDuration True (t 3661) @?= "1h01m01s"+ ]+ , testCase "Title layout" fitTests+ ]++-- Build a TimeSpec from a whole number of seconds.+t :: Integer -> TimeSpec+t s = TimeSpec (fromInteger s) 0++fitTests :: Assertion+fitTests = sequence_ do+ w <- [1..40]+ lsz <- [0..9]+ csz <- [0,1,4,5,6,8] -- always 6 currently+ rsz <- [0..9]+ let inp = (lsz, csz, rsz)+ let ans@Fit{..} = fitLCR w inp+ let go as wh = as (wh ++ " " ++ show (w, inp) ++ " -> " ++ show ans)+ pure do+ -- Check several invariants.+ go assertBool "Positive padl" $ padL > 0+ go assertBool "Positive padr" $ padR > 0 || (ctake == 0 && padR == 0)+ go assertBool "Nonnegative ctake" $ ctake >= 0+ go assertEqual "Total width" w $+ padL + padR + ctake + (if wide then lsz + rsz else 0)+ go assertEqual "Show iff possible" wide (lsz + csz + rsz + 2 <= w)+ when (padL > 1 && padR > 1) do+ go assertEqual "Full center if possible" ctake csz+ go assertBool "Centered if possible" $+ 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+
test/Main.hs view
@@ -2,22 +2,18 @@ import Test.Tasty -import BaseSpec qualified-import ConfigSpec qualified-import CoreSpec qualified+import ElementsSpec qualified import DecoderSpec qualified import PlaylistSpec qualified import StyleSpec qualified-import WidthSpec qualified+import TextSpec qualified main :: IO () main = defaultMain $ testGroup "hmp3-ng"- [ BaseSpec.tests- , ConfigSpec.tests- , CoreSpec.tests+ [ ElementsSpec.tests , DecoderSpec.tests , StyleSpec.tests , PlaylistSpec.tests- , WidthSpec.tests+ , TextSpec.tests ]
test/StyleSpec.hs view
@@ -3,6 +3,9 @@ import Test.Tasty import Test.Tasty.HUnit +import Control.Exception++import Base (isRight) import Style -- Lock in the config-string -> Color mapping and, with it, the intensity@@ -32,5 +35,25 @@ , testCase "unknown name" $ stringToColor "chartreuse" @?= Nothing ]+ , testGroup "styles"+ [ testStyles "built-in styles valid" [defaultStyle, monoStyle] True+ , testStyles "wrong style invalid" badStyles False+ ]+ ]++-- Check WHNF evaluation doesn't throw.+-- Suffices because UIStyle is recursively strict.+evalOk :: a -> IO Bool+evalOk = fmap isRight . try @SomeException . evaluate++testStyles :: Traversable t => String -> t UIStyle -> Bool -> TestTree+testStyles s m b = testCase s $ (@?= b) . and =<< traverse evalOk m++-- Test that test actually tests.+badStyles :: [UIStyle]+badStyles =+ [ defaultStyle+ , defaultStyle { window = style "badcolor" "default" }+ , defaultStyle ]
+ test/TextSpec.hs view
@@ -0,0 +1,94 @@+module TextSpec (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import Text++-- These tests depend on wcwidth's behavior under a UTF-8 locale and on a+-- handful of codepoints whose canonical widths are well-known:+-- * ASCII chars are 1 column.+-- * Latin-Extended chars (é, ñ) are 1 column.+-- * Common CJK chars (中) are 2 columns.+-- * The horizontal ellipsis (…) is 1 column.+-- They are not deterministic under the C locale.++tests :: TestTree+tests = testGroup "Text"+ [ testGroup "match"+ [ m (Just True) "exact" "foo" "fooBar"+ , m (Just True) "caseless" "FOO" "fooBar"+ , m Nothing "invalid" "[" "any[thing"+ , m (Just True) "alt" "(foo|az)Q" "bazQux"+ , m (Just True) "dot" "o.a" "foobar"+ , m (Just True) "Unicode" "jör" "Björk"+ , m (Just True) "dot Unicode" "j.r" "Björk"+ , m (Just True) "Nordic case" "bør" "BØrnE"+ , m (Just True) "Greek case" "Λω" "ΦλΩα"+ , m (Just True) "dot CJK" "中.人" "中國人"+ , m (Just False) "byte dots" "c..te" "côte"+ ]+ , testGroup "dropLastUTF8"+ [ testCase "ASCII" $ dropLastUTF8 "abc" @?= "ab"+ , testCase "empty" $ dropLastUTF8 "" @?= ""+ , testCase "French" $ dropLastUTF8 (u"été") @?= u"ét"+ , testCase "CJK" $ dropLastUTF8 (u"中國") @?= u"中"+ , testCase "Emoji" $ dropLastUTF8 (u"Yes👍") @?= u"Yes"+ , testCase "invalid" $ dropLastUTF8 "\x80" @?= ""+ ]+ , testGroup "trim"+ [ testCase "empty" $ trim "" @?= ""+ , 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"+ ]+ , testGroup "displayWidth"+ [ testCase "empty" $ displayWidth "" @?= 0+ , testCase "ascii" $ displayWidth "hello" @?= 5+ , testCase "latin-extended" $ displayWidth (u"café") @?= 4+ , testCase "cjk doubles each" $ displayWidth (u"中文") @?= 4+ , testCase "mixed" $ displayWidth (u"中a文b") @?= 6+ ]+ , testGroup "toMaxWidth"+ [ testCase "wider than input passes through"+ $ toMaxWidth 10 "hello" @?= "hello"+ , testCase "exactly the width passes through"+ $ toMaxWidth 5 "hello" @?= "hello"+ , testCase "truncate ascii with ellipsis"+ $ toMaxWidth 4 "hello" @?= "hel" <> u"…"+ , testCase "narrower truncate"+ $ toMaxWidth 2 "hello" @?= "h" <> u"…"+ , testCase "width one becomes a lone ellipsis"+ $ toMaxWidth 1 "hello" @?= u"…"+ , testCase "width zero becomes empty"+ $ toMaxWidth 0 "hello" @?= ""+ , testCase "wide char truncation respects boundaries"+ -- "中文hi" is 6 columns (2+2+1+1); toMaxWidth 4 keeps the first+ -- wide char plus two ellipses to fill the remaining columns.+ $ toMaxWidth 4 (u"中文hi") @?= u"中……"+ , testCase "wide char gives way to single ellipsis at the boundary"+ -- "中文" is 4 columns; toMaxWidth 3 keeps the first wide char+ -- (2 columns) plus one ellipsis (1 column).+ $ toMaxWidth 3 (u"中文") @?= u"中…"+ ]+ , testGroup "toWidth"+ [ testCase "pads short ascii"+ $ toWidth 10 "hello" @?= "hello "+ , testCase "pad with empty input"+ $ toWidth 4 "" @?= " "+ , testCase "exact width unchanged"+ $ toWidth 5 "hello" @?= "hello"+ , testCase "truncate matches toMaxWidth when over-width"+ $ toWidth 4 "hello" @?= u"hel…"+ , testCase "pads after a wide-char content too"+ $ toWidth 5 (u"中a") @?= u"中a "+ ]+ ]+++m :: Maybe Bool -> String -> String -> String -> TestTree+m b tag pat str = testCase tag $ ($ u str) <$> matches (u pat) @?= b+
− test/WidthSpec.hs
@@ -1,65 +0,0 @@-module WidthSpec (tests) where--import Test.Tasty-import Test.Tasty.HUnit--import Data.ByteString (ByteString)-import Data.ByteString.UTF8 qualified as UTF8--import Width (displayWidth, toMaxWidth, toWidth)---- These tests depend on wcwidth's behaviour under a UTF-8 locale and on a--- handful of codepoints whose canonical widths are well-known:--- * ASCII chars are 1 column.--- * Latin-Extended chars (é, ñ) are 1 column.--- * Common CJK chars (中) are 2 columns.--- * The horizontal ellipsis (…) is 1 column.--- They are not deterministic under the C locale.--tests :: TestTree-tests = testGroup "Width"- [ testGroup "displayWidth"- [ testCase "empty" $ displayWidth "" @?= 0- , testCase "ascii" $ displayWidth "hello" @?= 5- , testCase "latin-extended" $ displayWidth (u"café") @?= 4- , testCase "cjk doubles each" $ displayWidth (u"中文") @?= 4- , testCase "mixed" $ displayWidth (u"中a文b") @?= 6- ]- , testGroup "toMaxWidth"- [ testCase "wider than input passes through"- $ toMaxWidth 10 "hello" @?= "hello"- , testCase "exactly the width passes through"- $ toMaxWidth 5 "hello" @?= "hello"- , testCase "truncate ascii with ellipsis"- $ toMaxWidth 4 "hello" @?= "hel" <> u"…"- , testCase "narrower truncate"- $ toMaxWidth 2 "hello" @?= "h" <> u"…"- , testCase "width one becomes a lone ellipsis"- $ toMaxWidth 1 "hello" @?= u"…"- , testCase "width zero becomes empty"- $ toMaxWidth 0 "hello" @?= ""- , testCase "wide char truncation respects boundaries"- -- "中文hi" is 6 columns (2+2+1+1); toMaxWidth 4 keeps the first- -- wide char plus two ellipses to fill the remaining columns.- $ toMaxWidth 4 (u"中文hi") @?= u"中……"- , testCase "wide char gives way to single ellipsis at the boundary"- -- "中文" is 4 columns; toMaxWidth 3 keeps the first wide char- -- (2 columns) plus one ellipsis (1 column).- $ toMaxWidth 3 (u"中文") @?= u"中…"- ]- , testGroup "toWidth"- [ testCase "pads short ascii"- $ toWidth 10 "hello" @?= "hello "- , testCase "pad with empty input"- $ toWidth 4 "" @?= " "- , testCase "exact width unchanged"- $ toWidth 5 "hello" @?= "hello"- , testCase "truncate matches toMaxWidth when over-width"- $ toWidth 4 "hello" @?= "hel" <> u"…"- , testCase "pads after a wide-char content too"- $ toWidth 5 (u "中a") @?= u"中a" <> " "- ]- ]--u :: String -> ByteString-u = UTF8.fromString