hmp3-ng 2.18.0 → 2.18.1
raw patch · 18 files changed
+848/−1205 lines, 18 filesdep +posix-pathsdep ~base
Dependencies added: posix-paths
Dependency ranges changed: base
Files
- Base.hs +9/−7
- Core.hs +121/−119
- FastIO.hs +0/−89
- Keyboard.hs +31/−0
- Keymap.hs +45/−78
- Keymap.hs-boot +0/−10
- Lexer.hs +83/−119
- README.md +5/−2
- State.hs +57/−110
- Style.hs +1/−1
- Syntax.hs +5/−48
- Tree.hs +49/−50
- UI.hs +294/−402
- app/Main.hs +8/−4
- hmp3-ng.cabal +91/−79
- test/FastIOSpec.hs +0/−42
- test/LexerSpec.hs +49/−43
- test/Main.hs +0/−2
Base.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} --- Copyright (c) 2020-2025 Galen Huntington+-- Copyright (c) 2020-2026 Galen Huntington -- SPDX-License-Identifier: GPL-2.0-or-later module Base (module Prelude, module X, module Base) where@@ -19,13 +19,13 @@ import Data.Foldable as X import Data.Functor as X hiding (unzip) import Data.IORef as X-import Data.List as X+import Data.List as X hiding ((!?)) import Data.Maybe as X 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.Environment as X import System.Exit as X import System.IO as X (Handle, hClose) import System.IO.Unsafe as X@@ -47,8 +47,10 @@ Monotonic #endif -sequenceWhile :: Monad m => (a -> Bool) -> [m a] -> m [a]-sequenceWhile _ [] = pure []-sequenceWhile p (m:ms) = m >>= \a ->- if p a then (a:) <$> sequenceWhile p ms else pure []+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
Core.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-} -- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- Copyright (c) 2008, 2019-2026 Galen Huntington@@ -9,54 +9,52 @@ -- module Core ( Options(..),- start,- shutdown,+ start, shutdown, seekLeft, seekRight, upOne, downOne, pause, nextMode, playNext, playPrev,- forcePause, putmsg, clrmsg, toggleHelp, play, playCur,+ forcePause, putMessage, clearMessage, playCursor, playCur, jumpToPlaying, jump, jumpRel, upPage, downPage, seekStart, blacklist,- showHist, hideHist,+ setsModal, closeModal, showHist, jumpToMatchDir, jumpToMatchFile, toggleFocus, jumpToNextDir, jumpToPrevDir, loadConfig, discardErrors,- toggleExit, showTimeDiff_, ) where import Base import Syntax-import Lexer (parser)+import Lexer (mpgParser) import State import Style-import FastIO (FiltHandle(..), newFiltHandle) import Tree hiding (File, Dir) import qualified Tree (File,Dir) import qualified UI -import Text.Regex.PCRE.Light-import {-# SOURCE #-} Keymap (keyLoop)- import qualified Data.ByteString.Char8 as P import qualified Data.Sequence as Seq import Data.Array ((!), bounds, Array)+import Data.Proxy import Data.Tuple (swap) import Control.Monad.State.Strict import System.Directory (doesFileExist, findExecutable, createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))-import System.IO (hPutStrLn, hGetLine, stderr, hFlush)+import System.IO (hPutStrLn, hGetLine, stderr) import System.Process (runInteractiveProcess, waitForProcess) import System.Clock (TimeSpec(..), diffTimeSpec)-import System.Random (randomR)+import System.Random (randomR, newStdGen) import System.FilePath ((</>))+import System.Posix.FilePath (takeFileName) import System.Posix.Process (exitImmediately) +import Text.Regex.PCRE.Light + mp3Tool :: String mp3Tool = #ifdef MPG321@@ -73,17 +71,25 @@ , optConfigPath :: !(Maybe FilePath) -- ^ override the style.conf location } +-- | Sets up state, spawns sub-threads, and starts player. start :: Options -> Tree -> IO ()-start opts (Tree ds fs) = handle @SomeException (shutdown . Just . show) do-- c <- UI.start -- initialise curses+start opts (Tree folders music) = do - now <- getMonoTime+ config <- catch @SomeException UI.start \err -> do+ -- An uncaught exception here would deadlock.+ -- XXX more state model revisions should obviate need+ hPutStrLn stderr $ "Curses failed to start: " ++ show err+ exitImmediately (ExitFailure 1) *> error "Unix <2.8"+ bootTime <- getMonoTime+ let size = length music mode <- readState+ gen <- newStdGen+ let (current, randomGen) =+ if mode == Random then randomR (0, size-1) gen else (0, gen) threads <- traverse forkIO [ mpgLoop- , mpgInput readf+ , mpgInput readh , refreshLoop , clockLoop , uptimeLoop@@ -91,24 +97,39 @@ , if mp3Tool == "mpg321" then mpgInput errh else errorLoop ] - silentlyModifyHS $ \st -> st- { music = fs- , folders = ds- , size = 1 + (snd . bounds $ fs)- , cursor = 0- , current = 0- , mode = mode- , boottime = now- , config = c+ putMVar hState HState+ { music+ , folders+ , size+ , bootTime , configPath = optConfigPath opts- , threads }-- loadConfig+ , current+ , cursor = current+ , randomGen+ , mode+ , config+ , threads+ , spawns = 0+ , mpgPid = Nothing+ , clock = Nothing+ , info = Nothing+ , id3 = Nothing+ , regex = Nothing+ , modal = Nothing+ , playHist = mempty+ , searchHist = []+ , clockUpdate = False+ , miniFocused = False+ , exiting = False+ , status = Stopped+ , minibuffer = Fast mempty defaultSty+ , uptime = mempty+ } - if mode == Random then runPlayOp playRandomOp else playCur- when (optPaused opts) pause+ loadConfig -- TODO this should return config rather than setting it - run -- won't restart if this fails!+ playCur+ when (optPaused opts) pause -- TODO use LOADPAUSED? ------------------------------------------------------------------------ @@ -125,12 +146,12 @@ -- 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 e = False -- ignore- | is @ErrorCall e = False -- ignore+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 => SomeException -> Bool- is = isJust . fromException @e+ | otherwise = True+ where is :: forall e. Exception e => Proxy e -> SomeException -> Bool+ is _ = isJust . fromException @e ------------------------------------------------------------------------ @@ -151,7 +172,7 @@ Left (ex :: SomeException) -> warnA $ mppath ++ " failed to start; retrying: " ++ show ex - Right (writeh, r, e, pid) -> do+ Right (writeh, readh, errh, pid) -> do ct <- modifyHS $ \st -> let sp = spawns st + 1 in (st { mpgPid = Just pid , status = Stopped@@ -160,9 +181,7 @@ , spawns = sp }, sp) - readf <- newFiltHandle r- errh <- newFiltHandle e- putMVar mpg Mpg { readf, errh, writeh }+ putMVar mpg Mpg { readh, errh, writeh } when (ct > 1) $ warnA $ mp3Tool ++ " #" ++ show ct ++ ": Ready" catch @SomeException (void $ waitForProcess pid) (const $ pure ())@@ -171,7 +190,7 @@ silentlyModifyHS $ \st -> st { mpgPid = Nothing } void $ takeMVar mpg - stop <- getsHS doNotResuscitate+ stop <- getsHS exiting when stop exitSuccess threadDelay 1_000_000 -- let threads spit errors warnA $ "Restarting " ++ mppath ++ " ..."@@ -185,17 +204,16 @@ -- | When the editor state has been modified, refresh, then wait -- for it to be modified again. refreshLoop :: IO ()-refreshLoop = do- mvar <- getsHS modified- runForever $ takeMVar mvar >> UI.refresh+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- modifyHS_ $ \st -> st { uptime = showTimeDiff (boottime st) now }+ modifyHS_ $ \st -> st { uptime = showTimeDiff (bootTime st) now } threadDelay 3_000_000 ------------------------------------------------------------------------@@ -229,7 +247,7 @@ -- | Handle, and display errors produced by mpg123 errorLoop :: IO () errorLoop = runForever $- readMVar mpg <&> errh >>= hGetLine . filtHandle >>= (warnA . ("mpg: " ++))+ readMVar mpg <&> errh >>= hGetLine >>= (warnA . ("mpg123 err: " ++)) ------------------------------------------------------------------------ @@ -237,34 +255,31 @@ -- shutdown kills the other end of the pipe, hGetLine will fail, so we -- take that chance to exit. ---mpgInput :: (Mpg -> FiltHandle) -> IO ()+mpgInput :: (Mpg -> Handle) -> IO () mpgInput field = runForever $ do- res <- parser =<< field <$> readMVar mpg- case res of+ line <- P.hGetLine =<< field <$> readMVar mpg+ case mpgParser line of Right m -> handleMsg m- Left (Just e) -> (warnA . ("read: " ++) . show) e+ Left (Just e) -> warnA ("mpg123: " ++ e) _ -> pure () ------------------------------------------------------------------------ --- | The main thread: handle keystrokes fed to us by curses-run :: IO ()-run = runForever keyLoop--------------------------------------------------------------------------- -- | Close most things. Important to do all the jobs:+-- TODO maybe releaseSignals here in case mpg is frozen?+-- and/or move UI.end up? shutdown :: Maybe String -> IO () shutdown ms = do- silentlyModifyHS $ \st -> st { doNotResuscitate = True }+ silentlyModifyHS $ \st -> st { exiting = True } discardErrors writeState mpid <- getsHS mpgPid- flip (maybe $ pure ()) mpid \pid -> do+ whenJust mpid \pid -> do discardErrors $ sendMpg Quit void $ waitForProcess pid- UI.end =<< getsHS xterm- flip (maybe $ pure ()) ms \s -> hPutStrLn stderr s *> hFlush stderr- exitImmediately ExitSuccess+ UI.end+ exitImmediately =<< case ms of+ Just s -> hPutStrLn stderr s *> pure (ExitFailure 1)+ _ -> pure ExitSuccess ------------------------------------------------------------------------ -- @@ -272,13 +287,13 @@ -- right pigeon hole. -- handleMsg :: Msg -> IO ()-handleMsg (T _) = pure ()-handleMsg (I i) = modifyHS_ $ \s -> s { info = Just i }-handleMsg (F (File (Left _))) = modifyHS_ $ \s -> s { id3 = Nothing }-handleMsg (F (File (Right i))) = modifyHS_ $ \s -> s { id3 = Just i } +handleMsg (T _) = pure ()+handleMsg (I i) = modifyHS_ $ \s -> s { info = Just i }+handleMsg (F id3) = modifyHS_ $ \s -> s { id3 = Just id3 }+ handleMsg (S t) = do- modifyHS_ $ \s -> s { status = t }+ modifyHS_ $ \s -> s { status = t } when (t == Stopped) playNext -- transition to next song handleMsg (R f) = do@@ -305,13 +320,10 @@ -- | Generic seek seek :: (Frame -> Int) -> IO () seek fn = do- f <- getsHS clock- case f of- Nothing -> pure ()- Just g -> do- sendMpg $ Jump (fn g)- forceNextPacket -- don't drop the next Frame.- silentlyModifyHS $ \st -> st { clockUpdate = True }+ mfr <- getsHS clock+ whenJust mfr \fr -> do+ sendMpg $ Jump (fn fr)+ silentlyModifyHS $ \st -> st { clockUpdate = True } ------------------------------------------------------------------------@@ -358,14 +370,11 @@ -- | Operates on HState and outputs maybe a track to play. type PlayOp = State HState (Maybe Int) --- | Play the song under the cursor or random if that one is playing--- TODO these semantics are strange; maybe playNext instead of random?-play :: IO ()-play = runPlayOp do+-- | 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 playRandomOp- else pure $ Just cursor+ if current == cursor then playNextOp else pure $ Just cursor -- | Play the song under the cursor (from the start) playCur :: IO ()@@ -389,7 +398,10 @@ -- 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 do+playNext = runPlayOp playNextOp++playNextOp :: PlayOp+playNextOp = do HState { mode, current, size } <- get let next = current + 1 case mode of@@ -425,6 +437,7 @@ , status = Playing , cursor = if current == cursor then new else cursor , playHist = Seq.take 36 $ (now, new) Seq.<| playHist+ , id3 = Nothing } pure f forM_ mfile $ sendMpg . Load@@ -466,8 +479,8 @@ -- 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 -> FilePathP-instance Lookup Tree.Dir where extract = dname+class Lookup a where extract :: a -> RawFilePath+instance Lookup Tree.Dir where extract = takeFileName . dname instance Lookup Tree.File where extract = fbase jumpToMatchFile :: Maybe String -> Bool -> IO ()@@ -507,41 +520,34 @@ i:_ -> (st' { cursor = sel i st }, True) _ -> (st', False) - unless found $ putmsg (Fast "No match found." defaultSty) *> touchHS+ unless found $ putMessage $ Fast "No match found." defaultSty ------------------------------------------------------------------------ --- | Show/hide the help window-toggleHelp :: IO ()-toggleHelp = modifyHS_ $ \st -> st { helpVisible = not (helpVisible st) }---- | Focus the minibuffer-toggleFocus :: IO ()-toggleFocus = modifyHS_ $ \st -> st { miniFocused = not (miniFocused st) }---- | Show/hide the confirm exit modal-toggleExit :: IO ()-toggleExit = modifyHS_ $ \st -> st { exitVisible = not (exitVisible st) }+-- | General modal setting.+setsModal :: (HState -> Maybe Modal) -> IO ()+setsModal f = modifyHS_ $ \st -> st { modal = f st } --- | History on or off-hideHist :: IO ()-hideHist = modifyHS_ $ \st -> st { histVisible = Nothing }+-- | Close any open modal.+closeModal :: IO ()+closeModal = setsModal $ const Nothing +-- | Show history. showHist :: IO () showHist = do now <- getMonoTime- modifyHS_ $ \st -> st {- helpVisible = False,- histVisible = Just $ do- (tm, ix) <- toList $ playHist st- pure (showTimeDiff_ True tm now, (ix, fbase $ music st ! ix))- }+ setsModal \st -> Just $ HistModal [+ (showTimeDiff_ True tm now, (ix, fbase $ music st ! ix))+ | (tm, ix) <- toList $ playHist st ] +-- | Focus the minibuffer+toggleFocus :: IO ()+toggleFocus = modifyHS_ $ \st -> st { miniFocused = not (miniFocused st) }+ -- | Toggle the mode flag nextMode :: IO ()-nextMode = modifyHS_ $ \st -> st { mode = next (mode st) }- where- next v = if v == maxBound then minBound else succ v+nextMode = modifyHS_ $ \st -> st { mode = next (mode st) } where+ next v = if v == maxBound then minBound else succ v ------------------------------------------------------------------------ @@ -598,20 +604,16 @@ UI.resetui --------------------------------------------------------------------------- Editing the minibuffer+-- Set the minibuffer --- TODO maybe shouldn't be silent?-putmsg :: StringA -> IO ()-putmsg s = silentlyModifyHS $ \st -> st { minibuffer = s }+putMessage :: StringA -> IO ()+putMessage s = modifyHS_ \st -> st { minibuffer = s } --- | Modify without triggering a refresh-clrmsg :: IO ()-clrmsg = putmsg (Fast P.empty defaultSty)+clearMessage :: IO ()+clearMessage = putMessage $ Fast P.empty defaultSty --- warnA :: String -> IO () warnA x = do sty <- getsHS config- putmsg $ Fast (P.pack x) (warnings sty)- touchHS+ putMessage $ Fast (P.pack x) (warnings sty)
− FastIO.hs
@@ -1,89 +0,0 @@--- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019-2021, 2025 Galen Huntington--- SPDX-License-Identifier: GPL-2.0-or-later---- | ByteString versions of some common IO functions--module FastIO where--import Base--import qualified Data.ByteString.Char8 as B--import System.Posix.Files.ByteString-import System.Posix.Directory.ByteString------------------------------------------------------------------------------ Use every nth frame. 1 for no dropping.-dropRate :: Int-dropRate = 4 -- used to be 10, but computers are faster---- | Packed string version of basename-basenameP :: ByteString -> ByteString-basenameP fps = case B.elemIndexEnd '/' fps of- Nothing -> fps- Just i -> B.drop (i+1) fps-{-# INLINE basenameP #-}--dirnameP :: ByteString -> ByteString-dirnameP fps = case B.elemIndexEnd '/' fps of- Nothing -> "."- Just i -> B.take i fps-{-# INLINE dirnameP #-}---- | Packed version of listDirectory-packedGetDirectoryContents :: ByteString -> IO [ByteString]-packedGetDirectoryContents fp = bracket (openDirStream fp) closeDirStream- $ \ds -> fmap (filter (\p -> p/="." && p/=".."))- $ sequenceWhile (not . B.null) $ repeat $ readDirStream ds--doesFileExist :: ByteString -> IO Bool-doesFileExist fp = catch @SomeException- (not . isDirectory <$> getFileStatus fp)- (\_ -> pure False)--doesDirectoryExist :: ByteString -> IO Bool-doesDirectoryExist fp = catch @SomeException- (isDirectory <$> getFileStatus fp)- (\_ -> pure False)--packedFileNameEndClean :: ByteString -> ByteString-packedFileNameEndClean name =- case B.unsnoc name of- Just (name', ec) | ec == '\\' || ec == '/'- -> packedFileNameEndClean name'- _ -> name---- -----------------------------------------------------------------------data FiltHandle = FiltHandle { filtHandle :: !Handle, frameCount :: !(IORef Int) }--newFiltHandle :: Handle -> IO FiltHandle-newFiltHandle h = FiltHandle h <$> newIORef 0---- | Read a line from a file stream connected to an external prcoess,--- Returning a ByteString.-getPacket :: FiltHandle -> IO ByteString-getPacket (FiltHandle fp _) = B.hGetLine fp---- | Check if it's one of every dropRate packets.--- We don't need to process all since there are so many.-checkF :: FiltHandle -> IO Bool-checkF (FiltHandle _ ir) = do- modifyIORef' ir (\x -> (x+1) `mod` dropRate)- i <- readIORef ir- pure $ dropRate==1 || i==1---- -----------------------------------------------------------------------isReadable :: ByteString -> IO Bool-isReadable fp = fileAccess fp True False False-------------------------------------------------------------------------- ---- ----------------------------------------------------------------------trim :: ByteString -> ByteString-{-# INLINE trim #-}-trim = B.dropWhileEnd isSpace . B.dropSpace-
+ Keyboard.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- Copyright (c) 2019, 2023-2026 Galen Huntington+-- SPDX-License-Identifier: GPL-2.0-or-later++module Keyboard (unkey, charToKey, Key(..)) where++import Base++import qualified Data.Map.Strict as M+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+
Keymap.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS -Wno-orphans #-}- -- 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@@ -14,17 +12,17 @@ -- module Keymap (keyLoop, keyTable, unkey, charToKey) where -import Base hiding ((!?))+import Base import Core-import Config (package)-import State (getsHS, touchHS, modifyHS_, HState(histVisible, searchHist))-import Style (defaultSty, StringA(Fast))+import Config (package)+import Keyboard (unkey, charToKey, Key(..))+import State (getsHS, modifyHS_, KeysHelp, Modal(..), HState(..))+import Style (defaultSty, StringA(Fast)) import qualified UI (getKey, resetui) -import UI.HSCurses.Curses (Key(..), decodeKey)- import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.Map.Strict as M @@ -38,31 +36,43 @@ -- | Read keys forever and dispatch. Each round clears the minibuffer -- between the keystroke and the action so messages from the previous -- action remain visible until the user reacts.-keyLoop :: IO ()+keyLoop :: IO Void keyLoop = go mainMode where- go (KeyMap f) = UI.getKey >>= \c -> clrmsg *> f c >>= go+ go (KeyMap f) = UI.getKey >>= \c -> clearMessage *> f c >>= go ------------------------------------------------------------------------ -- Top-level normal mode mainMode :: KeyMap-mainMode = KeyMap dispatch where- dispatch 'q' = forcePause *> toggleExit *> touchHS $> confirmQuitMode- dispatch c- | c `elem` ['/', '?', '\\', '|']- = enterSearch c- | c `elem` ['H', ';'] = showHist *> touchHS $> historyMode- | c >= '1' && c <= '9' =+mainMode = KeyMap \c -> getsHS modal >>= \case++ Just ExitModal -> case c of+ 'y' -> shutdown Nothing $> undefined -- shutdown never returns+ _ -> 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 == 'q' ->+ forcePause *> setsModal (const $ Just ExitModal) $> mainMode+ | c `elem` ['H', ';'] ->+ showHist $> mainMode+ | c >= '1' && c <= '9' -> jumpRel (0.1 * fromIntegral (fromEnum c - 48)) $> mainMode- | True = sequence_ (M.lookup c keyMap) $> mainMode+ | True -> sequence_ (M.lookup c keyMap) $> mainMode - enterSearch stype = do- toggleFocus- hist <- getsHS searchHist- searchMode stype $ Zipper "" hist [] +historyKeyMap :: M.Map Char Int+historyKeyMap = M.fromList $ zip (['0'..'9'] ++ ['a'..'z']) [0..] + ------------------------------------------------------------------------ -- Search mode @@ -76,7 +86,7 @@ step z = renderSearch stype z $> KeyMap (`dispatch` z) dispatch c z- | c == '\ESC' = clrmsg *> touchHS *> leave+ | c == '\ESC' = clearMessage *> leave | c `elem` enter' = commit z | c `elem` delete' = step $ zipEdit dropLast z | k == KeyUp = step $ zipUp z@@ -86,7 +96,7 @@ | otherwise = step $ zipEdit (++ [c]) z where k = charToKey c - commit (Zipper [] _ _) = clrmsg *> touchHS *> leave+ commit (Zipper [] _ _) = clearMessage *> leave commit (Zipper pat _ _) = do let jumpy = if stype `elem` ['/', '?'] then jumpToMatchFile else jumpToMatchDir@@ -104,9 +114,7 @@ leave = toggleFocus $> mainMode renderSearch :: Char -> Zipper -> IO ()-renderSearch prefix z = do- putmsg $ Fast (P.pack (prefix : cur z)) defaultSty- touchHS+renderSearch prefix z = putMessage $ Fast (P.pack (prefix : cur z)) defaultSty dropLast :: [a] -> [a] dropLast [] = []@@ -121,54 +129,6 @@ zipDown (Zipper c b (pv:rest)) = Zipper pv (c:b) rest zipDown z = z ----------------------------------------------------------------------------- Song-history popup--historyMode :: KeyMap-historyMode = KeyMap \c -> do- for_ (M.lookup c historyKeys) \k -> do- phm <- getsHS histVisible- for_ (phm >>= (!? k)) (jump . fst . snd)- hideHist- touchHS- pure mainMode- where- historyKeys :: M.Map Char Int- historyKeys = M.fromList $ zip (['0'..'9'] ++ ['a'..'z']) [0..]-- -- Compatibility: List.!? only added in GHC 9.8- xs !? n = listToMaybe $ drop n xs------------------------------------------------------------------------------ Confirm-quit modal--confirmQuitMode :: KeyMap-confirmQuitMode = KeyMap \case- 'y' -> shutdown Nothing $> undefined -- shutdown never returns- _ -> toggleExit *> touchHS $> mainMode------------------------------------------------------------------------------ Char ↔ Key translation------ ncurses delivers special keys as integer codes ≥ 256; for everything--- in 0..255 'decodeKey' returns 'KeyChar (chr n)'. We keep working in--- 'Char' (UI.getKey's type), so we extend the range up to '\500' to--- cover the named keys we actually use (KEY_RESIZE is around 410).--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- enter', delete' :: [Char] enter' = ['\n', '\r'] delete' = ['\BS', '\DEL', unkey KeyBackspace]@@ -177,7 +137,7 @@ ------------------------------------------------------------------------ -- The keymap with help descriptions and actions. -keyTable :: [(String, [Char], IO ())]+keyTable :: [(ByteString, [Char], IO ())] keyTable = [ ("Move up", ['k',unkey KeyUp], upOne) , ("Move down", ['j',unkey KeyDown], downOne)@@ -189,7 +149,7 @@ , ("Seek left within song", [unkey KeyLeft], seekLeft) , ("Seek right within song", [unkey KeyRight], seekRight) , ("Toggle pause", [' '], pause)- , ("Play song under cursor", ['\n'], play)+ , ("Play from cursor", ['\n'], playCursor) , ("Play previous track", ['K'], playPrev) , ("Play next track", ['J'], playNext) , ("Toggle the help screen", ['h'], toggleHelp)@@ -209,11 +169,18 @@ , ("Search backwards for file", ['?'], placeholder) , ("Search for directory matching regex", ['\\'], placeholder) , ("Search backwards for directory", ['|'], placeholder)- , ("Quit " ++ package, ['q'], placeholder)+ , ("Quit " <> UTF8.fromString package, ['q'], placeholder) ] where placeholder = pure () -- handled separately -- Compiled dispatch table for normal-mode single-key commands. keyMap :: M.Map Char (IO ()) keyMap = M.fromList [ (c, a) | (_, cs, a) <- keyTable, c <- cs ]++keysHelp :: [KeysHelp]+keysHelp = [ (keys, desc) | (desc, keys, _) <- keyTable ]++toggleHelp :: IO ()+toggleHelp = setsModal \st ->+ if isNothing $ modal st then Just $ HelpModal keysHelp else Nothing
− Keymap.hs-boot
@@ -1,10 +0,0 @@-module Keymap where--import UI.HSCurses.Curses (Key)--keyLoop :: IO ()--keyTable :: [(String, [Char], IO ())]-unkey :: Key -> Char-charToKey :: Char -> Key-
Lexer.hs view
@@ -4,147 +4,111 @@ -- Lexer for mpg123 messages -module Lexer ( parser, doP, doF, doS, doI ) where+module Lexer ( mpgParser ) where import Base--import Syntax (Msg(..),Status(..),Frame(..),Info(..),Id3(..),File(..),Tag(..))-import FastIO (FiltHandle(..), checkF, getPacket, trim)+import Syntax (Msg(..), Status(..), Frame(..), Info(..), Id3(..), Tag(..)) import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.UTF8 as UTF8-import Control.Monad.Except-import Control.Monad.Trans (lift) ------------------------------------------------------------------------ -readPS :: ByteString -> Int-readPS = fst . fromJust . P.readInt+-- | Strip leading and trailing whitespace.+trim :: ByteString -> ByteString+trim = P.dropWhileEnd isSpace . P.dropSpace -doP :: ByteString -> Msg-doP s = S case fst <$> P.uncons s of- Just '0' -> Stopped- Just '1' -> Paused- Just '2' -> Playing- -- mpg123 outputs this but then @P 0 causing double Plays- -- (I think old mpg123 didn't do @P 0 so I added this)- -- '3' -> Stopped -- used by mpg123 for end of song- _ -> Playing- -- _ -> error "Invalid Status"+readPS :: ByteString -> Maybe Int+readPS = fmap fst . P.readInt +doP :: ByteString -> Maybe Msg+doP s = do+ (p, _) <- P.uncons s+ case p of+ '0' -> pure $ S Stopped+ '1' -> pure $ S Paused+ '2' -> pure $ S Playing+ -- recent mpg123 outputs 3 for end of song; don't need+ _ -> Nothing+ -- Frame decoding status updates (once per frame).-doF :: ByteString -> Msg-doF s = R Frame {- currentFrame = readPS f0- , framesLeft = readPS f1- , currentTime = read . P.unpack $ f2- , timeLeft = max 0 . read . P.unpack $ f3- }- where- f0 : f1 : f2 : f3 : _ = P.split ' ' s+doF :: ByteString -> Maybe Msg+doF s = do+ f0 : f1 : f2 : f3 : _ <- pure $ P.split ' ' s+ currentFrame <- readPS f0+ framesLeft <- readPS f1+ currentTime <- readMaybe $ P.unpack f2+ timeLeft <- max 0 <$> readMaybe (P.unpack f3)+ pure $ R Frame { currentFrame , framesLeft, currentTime, timeLeft } --- Outputs information about the mp3 file after loading.-doS :: ByteString -> Msg-doS s = let fs = P.split ' ' s- in I Info {- {-- version = fs !! 0- , layer = read . P.unpack $ fs !! 1- , sampleRate = read . P.unpack $ fs !! 2- , playMode = fs !! 3- , modeExtns = read . P.unpack $ fs !! 4- , bytesPerFrame = read . P.unpack $ fs !! 5- , channelCount = read . P.unpack $ fs !! 6- , copyrighted = toEnum (read $ P.unpack (fs !! 7))- , checksummed = toEnum (read $ P.unpack (fs !! 8))- , emphasis = read $ P.unpack $ fs !! 9- , bitrate = read $ P.unpack $ fs !! 10- , extension = read $ P.unpack $ fs !! 11- -}- userinfo = mconcat- ["mpeg "- ,fs !! 0- ," "- ,fs !! 10- ,"kbit/s "- ,(P.pack . show) (readPS (fs !! 2) `div` 1000 :: Int)- ,"kHz"]- }+-- Info about mp3 file after loading.+-- Breakdown from mpg123 README.remote (as numbers):+-- 0 = mpeg type (string)+-- 1 = layer (int)+-- 2 = sampling frequency (int)+-- 3 = mode (string)+-- 4 = mode extension (int)+-- 5 = framesize (int)+-- 6 = stereo (int)+-- 7 = copyright (int)+-- 8 = error protection (int)+-- 9 = emphasis (int)+-- 10 = bitrate (int)+-- 11 = extension (int)+doS :: ByteString -> Maybe Msg+doS s = do+ let fs = P.split ' ' s+ guard $ length fs >= 11+ hz <- readPS $ fs !! 2+ pure $ I $ Info $ mconcat [+ "mpeg ", fs !! 0, " ", fs !! 10, "kbit/s ",+ P.pack $ show $ hz `div` 1000, "kHz"] -- Track info if ID fields are in the file, otherwise file name.--- 30 chars per field?-doI :: ByteString -> Msg-doI s = let f = trim s- in case P.take 4 f of- cs | cs == "ID3:" -> F . File $- let ttl = toId id3 . splitUp . P.drop 4 $ f- -- mpg123 sometimes returns null titles- in if P.null (id3title ttl) then Left f else Right ttl- | otherwise -> F . File . Left $ f- where- -- a default- id3 :: Id3- id3 = Id3 "" "" "" ""-- -- break the ID3 string up- splitUp :: ByteString -> [ByteString]- splitUp f- | f == P.empty = []- | otherwise- = let (a,xs) = P.splitAt 30 f -- we expect it to be - xs' = splitUp xs- in a : xs'-- -- and some ugly code:- toId :: Id3 -> [ByteString] -> Id3- toId i ls =- let arg n = normalise $ ls !! n- j = case length ls of- 0 -> i-- 1 -> i { id3title = arg 0 }-- 2 -> i { id3title = arg 0- , id3artist = arg 1 }-- _ -> i { id3title = arg 0- , id3artist = arg 1- , id3album = arg 2 }+doI :: ByteString -> Maybe Msg+doI s = F <$> do+ ("ID3:", info) <- pure $ P.splitAt 4 s+ let id3 = parseId3 info+ guard $ not $ P.null $ id3title id3 -- title sometimes empty+ pure id3 - in j { id3str =- mconcat $ intersperse " : " $ filter (not . P.null)- [id3artist j, id3album j, id3title j] }+-- Format: title (30), author (30), album (30), year (4), comment (30), genre+-- We currently only use the first three.+parseId3 :: ByteString -> Id3+parseId3 = toId . cut where+ cut f | P.null f = []+ | True = let (a, xs) = P.splitAt 30 f in normalise a : cut xs+ toId ls = Id3 (arg 0) (arg 1) (arg 2) $ mconcat $ intersperse " : "+ $ filter (not . P.null) [arg 1, arg 2, arg 0]+ where arg = fromMaybe "" . (ls !?) - -- strip spaces, and decide if UTF-8 or ISO-8859-1- 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+-- | 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 ------------------------------------------------------------------------ -parser :: FiltHandle -> IO (Either (Maybe String) Msg)-parser h = runExceptT do- x <- lift $ getPacket h+-- 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 skip = throwError Nothing+ let quiet = maybe (Left Nothing) pure - when (P.length x < 3) skip- let (pre, m) = P.splitAt 3 x- at : code : sp : _ = P.unpack pre- when (at /= '@' || sp /= ' ') skip+ code <- quiet do+ '@' : c : ' ' : _ <- pure $ P.unpack line+ pure c - -- TODO: make doX functions total+ let m = P.drop 3 line case code of 'R' -> pure $ T Tag- 'I' -> pure $ doI m- 'S' -> pure $ doS m- 'F' -> do- b <- lift $ checkF h- if b then pure $ doF m else skip- 'P' -> pure $ doP m- 'E' -> throwError $ Just $ "mpg123 error: " ++ P.unpack m- _ -> skip+ 'I' -> quiet $ doI m+ 'S' -> quiet $ doS m+ 'F' -> quiet $ doF m+ 'P' -> quiet $ doP m+ 'E' -> Left $ Just $ P.unpack m+ _ -> quiet Nothing
README.md view
@@ -20,14 +20,17 @@ regeneration of a `configure` file (now gone). * The code has been updated to compile under recent GHC (tested-through 9.10) and libraries. This required rewriting or entirely-replacing large sections, mainly low-level optimizations.+through 9.14; minimum supported 9.0) and libraries. This required+rewriting or entirely replacing large sections, mainly low-level+optimizations. * I added support for building with Stack. It can also be installed with Nix from nixpkgs (`haskellPackages.hmp3-ng`). * There is a public GitHub issue tracker, and a GitHub action to continuously test builds.++* There is a test suite built on the Tasty framework. * I try to avoid “Not Invented Here” by using established, up-to-date packages from Hackage. Much old code has now been
State.hs view
@@ -9,119 +9,80 @@ import Base -import FastIO (FiltHandle(..))-import Syntax (Status(Stopped), Mode(..), Frame, Info, Id3, Pretty(ppr))+import Syntax (Status, Mode, Frame, Info, Id3, Pretty(ppr)) import Tree (FileArray, DirArray)-import Style (StringA(Fast), defaultSty, UIStyle)-import qualified Config (defaultStyle)+import Style (StringA, UIStyle) -import Text.Regex.PCRE.Light (Regex)-import Data.Array (listArray) import Data.ByteString (hPut) import Data.Sequence (Seq) import System.Clock (TimeSpec(..)) import System.IO (hFlush) import System.Process (ProcessHandle)-import System.Random+import System.Random (StdGen)+import Text.Regex.PCRE.Light (Regex) --- | The editor state type-data HState = HState {- music :: !FileArray- ,folders :: !DirArray- ,size :: !Int -- cache size of list- ,current :: !Int -- currently playing mp3- ,cursor :: !Int -- mp3 under the cursor- ,clock :: !(Maybe Frame) -- current clock value- ,clockUpdate :: !Bool- ,randomGen :: !StdGen -- random seed- ,mpgPid :: !(Maybe ProcessHandle) -- pid of decoder- ,spawns :: !Integer -- count of decoder spawns- ,threads :: ![ThreadId] -- all our threads- ,id3 :: !(Maybe Id3) -- maybe mp3 id3 info- ,info :: !(Maybe Info) -- mp3 info- ,status :: !Status- ,minibuffer :: !StringA -- contents of minibuffer- ,helpVisible :: !Bool -- is the help window shown?- ,histVisible :: !(Maybe [(ByteString, (Int, ByteString))]) -- history pop-up if shown- ,exitVisible :: !Bool -- confirm exit modal shown- ,miniFocused :: !Bool -- is the mini buffer focused?- ,mode :: !Mode- ,uptime :: !ByteString- ,boottime :: !TimeSpec- ,regex :: !(Maybe (Regex,Bool)) -- most recent search pattern and direction- ,searchHist :: ![String] -- history of searches- ,xterm :: !Bool- ,doNotResuscitate :: !Bool -- should we just let mpg123 die?- ,playHist :: !(Seq (TimeSpec, Int)) -- limited history of songs played- ,config :: !UIStyle -- config values- ,configPath :: !(Maybe FilePath) -- style.conf override (CLI)-- ,modified :: !(MVar ()) -- Set when redrawable components of - -- the state are modified. The ui- -- refresh thread waits on this.- ,drawLock :: !(MVar ()) -- simple semaphore for display+-- | Player state+data HState = HState+ -- These never change+ { music :: !FileArray+ , folders :: !DirArray+ , size :: !Int -- cache size of list+ , bootTime :: !TimeSpec+ , configPath :: !(Maybe FilePath) -- style.conf override (CLI)+ -- These can+ , current :: !Int -- currently playing mp3+ , cursor :: !Int -- mp3 under the cursor+ , clock :: !(Maybe Frame) -- current clock value+ , clockUpdate :: !Bool+ , randomGen :: !StdGen -- random seed+ , mpgPid :: !(Maybe ProcessHandle) -- pid of decoder+ , spawns :: !Integer -- count of decoder spawns+ , threads :: ![ThreadId] -- all our threads+ , id3 :: !(Maybe Id3) -- maybe mp3 id3 info+ , info :: !(Maybe Info) -- mp3 info+ , status :: !Status+ , minibuffer :: !StringA -- contents of minibuffer+ , modal :: !(Maybe Modal) -- modal visible+ , miniFocused :: !Bool -- is the mini buffer focused?+ , mode :: !Mode+ , uptime :: !ByteString+ , regex :: !(Maybe (Regex,Bool)) -- most recent search pattern and direction+ , searchHist :: ![String]+ , exiting :: !Bool -- let mpg123 die?+ , playHist :: !(Seq (TimeSpec, Int))+ , config :: !UIStyle } ------------------------------------------------------------------------------- | The initial state----newEmptyHS :: IO HState-newEmptyHS = do- modified <- newEmptyMVar- drawLock <- newMVar ()- randomGen <- newStdGen- pure HState {- music = listArray (0,0) []- ,folders = listArray (0,0) []-- ,size = 0- ,current = 0- ,cursor = 0-- ,threads = []- ,modified-- ,mpgPid = Nothing- ,spawns = 0- ,clock = Nothing- ,info = Nothing- ,id3 = Nothing- ,regex = Nothing- ,searchHist = []+-- Each is (timestamp-string, (song-index, song-name)).+type HistDisplay = [(ByteString, (Int, ByteString))] - ,clockUpdate = False- ,helpVisible = False- ,histVisible = Nothing- ,exitVisible = False- ,miniFocused = False- ,xterm = False- ,doNotResuscitate = False -- mpg123 should be restarted+-- (list-of-keys, description)+type KeysHelp = ([Char], ByteString) - ,randomGen- ,playHist = mempty- ,config = Config.defaultStyle- ,configPath = Nothing- ,boottime = 0- ,status = Stopped- ,mode = minBound- ,minibuffer = Fast mempty defaultSty- ,uptime = mempty- ,drawLock- }+data Modal = HelpModal ![KeysHelp] | ExitModal | HistModal !HistDisplay --- -- | A global variable holding the state.--- hState :: MVar HState-hState = unsafePerformIO $ newMVar =<< newEmptyHS+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.+ data Mpg = Mpg { writeh :: !Handle- , readf :: !FiltHandle- , errh :: !FiltHandle+ , readh :: !Handle+ , errh :: !Handle } mpg :: MVar Mpg@@ -139,28 +100,14 @@ getsHS :: (HState -> a) -> IO a getsHS f = f <$> readMVar hState --- | Modify the state with a pure function+-- | 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 <* touchHS+modifyHS_ f = silentlyModifyHS f <* setModified -- | Modify the state returning a value modifyHS :: (HState -> (HState, a)) -> IO a-modifyHS f = modifyMVar hState (pure . f) <* touchHS---- | Trigger a refresh. This is the only way to update the screen.-touchHS :: IO ()-touchHS = withMVar hState \st -> void $ tryPutMVar (modified st) ()--forceNextPacket :: IO ()-forceNextPacket = do- fh <- readf <$> readMVar mpg- writeIORef (frameCount fh) 0--withDrawLock :: IO () -> IO ()-withDrawLock io = do- lock <- getsHS drawLock- withMVar lock $ const io+modifyHS f = modifyMVar hState (pure . f) <* setModified
Style.hs view
@@ -10,7 +10,7 @@ import Base import qualified UI.HSCurses.Curses as Curses-import qualified Data.Map as M (fromList, empty, lookup, Map)+import qualified Data.Map as M ------------------------------------------------------------------------
Syntax.hs view
@@ -52,10 +52,6 @@ data Tag = Tag deriving stock (Eq, Show) --- Track info if ID fields are in the file, otherwise file name.-newtype File = File (Either ByteString Id3)- deriving stock (Eq, Show)- -- ID3 info data Id3 = Id3 { id3title :: !ByteString@@ -69,47 +65,13 @@ -- , genre :: Maybe ByteString } ---- Outputs information about the mp3 file after loading.--- <a>: version of the mp3 file. Currently always 1.0 with madlib, but don't --- depend on it, particularly if you intend portability to mpg123 as well.--- Float/string.--- <b>: layer: 1, 2, or 3. Integer.--- <c>: Samplerate. Integer.--- <d>: Mode string. String.--- <e>: Mode extension. Integer.--- <f>: Bytes per frame (estimate, particularly if the stream is VBR). Integer.--- <g>: Number of channels (1 or 2, usually). Integer.--- <h>: Is stream copyrighted? (1 or 0). Integer.--- <i>: Is stream CRC protected? (1 or 0). Integer.--- <j>: Emphasis. Integer.--- <k>: Bitrate, in kbps. (i.e., 128.) Integer.--- <l>: Extension. Integer.-newtype Info = Info {- userinfo :: ByteString -- user friendly string- -- version :: !ByteString,- -- layer :: !Int, -- 1,2 or 3- -- sampleRate :: !Int,- -- playMode :: !ByteString,- -- modeExtns :: !Int,- -- bytesPerFrame :: !Int,- -- channelCount :: !Int,- -- copyrighted :: !Bool,- -- checksummed :: !Bool,- -- emphasis :: !Int,- -- bitrate :: !Int,- -- extension :: !Int- }+-- mp3 file info; TODO maybe don't need this newtype at all?+newtype Info = Info { userinfo :: ByteString } deriving stock (Eq, Show) --- @F <current-frame> <frames-remaining> <current-time> <time-remaining> -- 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.------ Only 1 frame a second is actually read, so make sure it's lazy so--- there's no need to evaluate all the others. --- data Frame = Frame { currentFrame :: !Int, framesLeft :: !Int,@@ -118,14 +80,8 @@ } deriving stock (Eq, Show) --- @P {0, 1, 2} -- Stop/pause status.--- 0 - playing has stopped. When 'STOP' is entered, or the mp3 file is finished.--- 1 - Playing is paused. Enter 'PAUSE' or 'P' to continue.--- 2 - Playing has begun again.-data Status = Stopped- | Paused- | Playing+data Status = Stopped | Paused | Playing deriving stock (Eq, Show) data Mode = Once | Loop | Random | Single@@ -143,8 +99,9 @@ -- And a wrapper type -- data Msg = T {-# UNPACK #-} !Tag- | F !File+ | F !Id3 | I {-# UNPACK #-} !Info | R {-# UNPACK #-} !Frame | S !Status deriving stock (Eq, Show)+
Tree.hs view
@@ -6,20 +6,19 @@ -- functions for manipulating file trees -- -module Tree where+module Tree (module Tree, RawFilePath) where -import Base hiding (partition)+import Base -import FastIO import qualified Data.ByteString.Char8 as P import qualified Data.Map.Strict as M import Data.Array-import System.IO (hPrint, stderr)+import System.Posix.FilePath+import System.Posix.Files.ByteString (getFileStatus, isDirectory, fileAccess)+import System.Posix.Directory.Traversals (getDirectoryContents) -type FilePathP = ByteString- -- | A filesystem hierarchy is flattened to just the end nodes type DirArray = Array Int Dir @@ -29,14 +28,14 @@ -- | A directory entry is the directory name, and a list of bound -- indicies into the Files array. data Dir =- Dir { dname :: !FilePathP -- ^ directory name+ 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 :: !FilePathP -- ^ basename of file+ File { fbase :: !RawFilePath -- ^ basename of file , fdir :: !Int } -- ^ index of Dir entry data Tree = Tree !DirArray !FileArray@@ -44,9 +43,11 @@ -- -- | Given the start directories, populate the dirs and files arrays ---buildTree :: [FilePathP] -> IO Tree+buildTree :: [RawFilePath] -> IO Tree buildTree fs = do- (os, dirs) <- partition fs -- note we will lose the ordering of files given on cmd line.+ -- 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@@ -70,67 +71,65 @@ isEmpty (Tree _ files) = null files -- | Create nodes based on dirname for orphan files on cmdline-doOrphans :: [FilePathP] -> [(FilePathP, [FilePathP])]-doOrphans = map \f -> (dirnameP f, [basenameP f])+doOrphans :: [RawFilePath] -> [(RawFilePath, [RawFilePath])]+doOrphans = map \f -> (takeDirectory f, [takeFileName f]) -- | Merge entries with the same root node into a single node-merge :: [(FilePathP, [FilePathP])] -> [(FilePathP, [FilePathP])]+merge :: [(RawFilePath, [RawFilePath])] -> [(RawFilePath, [RawFilePath])] merge = M.assocs . M.fromListWith (flip (++)) -- | fold builder, for generating Dirs and Files-make :: (Int,Int,[Dir],[File]) -> (FilePathP,[FilePathP]) -> (Int,Int,[Dir],[File])+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 (basenameP f) i+ makeFile f = File (takeFileName f) i ------------------------------------------------------------------------ --- | Expand a single directory into a maybe a pair of the dir name and any files+-- | 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 :: FilePathP -> IO (Maybe (FilePathP, [FilePathP]), [FilePathP])+expandDir :: RawFilePath -> IO (Maybe (RawFilePath, [RawFilePath]), [RawFilePath]) expandDir !f = do- ls_raw <- handle @SomeException (\e -> hPrint stderr e $> [])- $ packedGetDirectoryContents f- let ls = (map \s -> P.intercalate (P.singleton '/') [f,s])- . sort . filter validFiles $ ls_raw- (fs',ds) <- partition ls- let fs = filter onlyMp3s fs'- v = if null fs then Nothing else Just (f,fs)- pure (v,ds)+ 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- validFiles = not . P.isPrefixOf "."- onlyMp3s = P.isSuffixOf ".mp3" . P.map toLower+ notHidden = not . P.isPrefixOf "."+ isMp3 = (== ".mp3") . P.map toLower . takeExtension ------ | Given an the next index into the files array, a directory name, and+-- | 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 -> FilePathP -> [FilePathP] -> (Dir, Int)-listToDir n d fs =- let dir = Dir { dname = packedFileNameEndClean d- , dsize = len- , dlo = n- , dhi = n + len - 1- } in (dir, n')- where- len = length fs- n' = n + len+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 list of file paths into a pair of sublists corresponding--- to the paths that point to files and to directories.-partition :: [FilePathP] -> IO ([FilePathP], [FilePathP])-partition [] = pure ([],[])-partition (a:xs) = do- (fs,ds) <- partition xs- x <- doesFileExist a- if x then do y <- isReadable a- pure if y then (a:fs, ds) else (fs, ds)- else pure (fs, a:ds)+-- | Break a pair of sublists of files and directories, filtering+-- out ones without permission.+sift :: [RawFilePath] -> IO ([RawFilePath], [RawFilePath])+sift [] = pure ([], [])+sift (p:ps) = do+ it@(fs,ds) <- sift ps+ isDir <- isDirectory <$> getFileStatus p+ perm <- fileAccess p True False isDir+ pure if+ | not perm -> it+ | isDir -> (fs, p:ds)+ | True -> (p:fs, ds)
UI.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE ForeignFunctionInterface, TupleSections, AllowAmbiguousTypes #-}- -- 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@@ -15,7 +13,7 @@ module UI ( runDraw, -- * Construction, destruction- start, end, suspend, screenSize, refresh, refreshClock, resetui,+ start, end, screenSize, refresh, refreshClock, resetui, -- * Input getKey ) where@@ -23,19 +21,19 @@ import Base import Style-import FastIO (basenameP) import Tree (File(fdir, fbase), Dir(dname)) import State import Syntax import Config import Width (displayWidth, toMaxWidth, toWidth) import qualified UI.HSCurses.Curses as Curses-import {-# SOURCE #-} Keymap (keyTable, unkey, charToKey)+import Keyboard (unkey, charToKey) import Data.Array ((!), bounds, Array) import Data.Array.Base (unsafeAt)+import System.Posix.FilePath (takeFileName) import System.IO (stderr, hFlush)-import System.Posix.Signals (raiseSignal, sigTSTP, installHandler, Handler(..))+import System.Posix.Signals (installHandler, Handler(..)) import Foreign.C.String import Foreign.C.Types@@ -52,26 +50,22 @@ newtype Draw = Draw (IO ())-instance Semigroup Draw where Draw x <> Draw y = Draw $ x >> y-instance Monoid Draw where mempty = Draw $ pure ()+ deriving newtype (Semigroup, Monoid) +drawLock :: MVar ()+drawLock = unsafePerformIO $ newMVar ()+{-# NOINLINE drawLock #-}+ runDraw :: Draw -> IO ()-runDraw (Draw d) = withDrawLock d+runDraw (Draw io) = withMVar drawLock $ const io ------------------------------------------------------------------------ -- | Initialize the UI start :: IO UIStyle start = do- discardErrors do- thisterm <- lookupEnv "TERM"- case thisterm of - Just "vt220" -> setEnv "TERM" "xterm-color"- Just t | "xterm" `isPrefixOf` t - -> silentlyModifyHS $ \st -> st { xterm = True }- _ -> pure ()- Curses.initCurses+ case Curses.cursesSigWinch of Just wch -> void $ installHandler wch (Catch resetui) Nothing _ -> pure () -- handled elsewhere@@ -93,23 +87,14 @@ nocursor :: Draw nocursor = Draw $ discardErrors $ void $ Curses.cursSet Curses.CursorInvisible ------ | Clean up and go home. Refresh is needed on linux. grr.----end :: Bool -> IO ()-end isXterm = withDrawLock do- when isXterm $ setXtermTitle ["xterm"]+-- | 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 ------ | Suspend the program----suspend :: IO ()-suspend = raiseSignal sigTSTP---- -- | Find the current screen height and width.--- screenSize :: IO (Int, Int) screenSize = Curses.scrSize @@ -172,6 +157,7 @@ data Pos = Pos { posY, _posX :: !Int } data Size = Size { _sizeH, sizeW :: !Int } +-- | Renderable widgets are functions @DrawData -> ...@. data DrawData = DD { drawSize :: Size, drawPos :: Pos,@@ -179,452 +165,364 @@ drawFrame :: Maybe Frame } ------ | A class for renderable objects, given the application state, and--- for printing the object as a list of strings----class Element a where draw :: DrawData -> a------- | The elements of the play mode widget----data PlayScreen = PlayScreen !PPlaying !ProgressBar !PTimes ---- | How does this all work? Firstly, we mostly want to draw fast strings--- directly to the screen. To break the drawing problem down, you need--- to write an instance of Element for each element in the ui. Larger--- and larger elements then combine these items together. ------ Obviously to write the element instance, you need a new type for each--- element, to disinguish them. As follows:--newtype PlayList = PlayList [StringA]--newtype PPlaying = PPlaying StringA-newtype PVersion = PVersion ByteString-newtype PMode = PMode String-newtype PMode2 = PMode2 String-newtype ProgressBar = ProgressBar StringA-newtype PTimes = PTimes StringA--newtype PInfo = PInfo ByteString-newtype PId3 = PId3 ByteString-newtype PTime = PTime ByteString--newtype PlayTitle = PlayTitle StringA-newtype PlayInfo = PlayInfo ByteString-newtype PlayModes = PlayModes String--data HelpModal-data HistModal-data ExitModal-class ModalElement a where- -- takes style, window width, state; returns (width, list of lines)- drawModal :: Style -> Int -> HState -> Maybe (Int, [StringA])----------------------------------------------------------------------------instance Element PlayScreen where- draw dd = PlayScreen (draw dd) (draw dd) (draw dd)---- | Decode the play screen-printPlayScreen :: PlayScreen -> [StringA]-printPlayScreen (PlayScreen (PPlaying a) - (ProgressBar b) - (PTimes c)) = [a , b , c]+-- screen width -> (modal width, list of lines)+type ModalMaker = Int -> (Int, [ByteString]) ------------------------------------------------------------------------ -instance (Element a, Element b) => Element (a, b) where- draw dd = (draw dd, draw dd)+-- | The three lines of the play-mode widget.+playScreen :: DrawData -> [StringA]+playScreen dd = [pPlaying dd, progressBar dd, pTimes dd] ------------------------------------------------------------------------ --- Info about the current track-instance Element PPlaying where- draw dd =- PPlaying . FancyS $ map (, defaultSty) $ " " : line- where- x = sizeW $ drawSize dd- PId3 a = draw dd- PInfo b = draw dd- 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 []+-- | Info about the current track+pPlaying :: DrawData -> StringA+pPlaying dd = FancyS $ map (, defaultSty) $ " " : line where+ x = sizeW $ drawSize dd+ a = pId3 dd+ b = pInfo dd+ 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-instance Element PId3 where- draw DD{drawState=st} = case id3 st of- Just i -> PId3 $ id3str i- Nothing -> PId3 $ case size st of- 0 -> "(empty)"- _ -> fbase $ music st ! current st+-- | Id3 info+pId3 :: DrawData -> ByteString+pId3 DD{drawState=st} = case id3 st of+ Just i -> id3str i+ Nothing -> case size st of+ 0 -> "(empty)"+ _ -> fbase $ music st ! current st -- | mp3 information-instance Element PInfo where- draw DD{drawState=st} = PInfo case info st of- Nothing -> "(empty)"- Just i -> userinfo i+pInfo :: DrawData -> ByteString+pInfo DD{drawState=st} = case info st of+ Nothing -> "(empty)"+ Just i -> userinfo i -modalWidth :: Int -> Int-modalWidth w = max (min w 3) $ round $ fromIntegral w * (0.8::Float)+commonModalWidth :: Int -> Int+commonModalWidth w = max (min w 3) $ round $ fromIntegral w * (0.8::Float) ------------------------------------------------------------------------ --- instance ModalElement me => Element (Modal me) where draw = drawModal--instance ModalElement HelpModal where- drawModal sty swd st = do- guard $ helpVisible st- pure (wd, [ Fast (f cs h) sty | (h, cs, _) <- keyTable ])- where- wd = modalWidth swd- f :: [Char] -> String -> ByteString- f cs ps = toWidth wd $ toWidth clen cmds <> u ps where- clen = max 4 $ round $ fromIntegral wd * (0.2::Float)- cmds = P.unwords ("" : map pprIt cs)- pprIt c = case c of- '\n' -> "Enter"- '\f' -> "^L"- '\\' -> "\\"- ' ' -> "Space"- _ -> case charToKey c of- Curses.KeyUp -> u"↑"- Curses.KeyDown -> u"↓"- Curses.KeyPPage -> "PgUp"- Curses.KeyNPage -> "PgDn"- Curses.KeyLeft -> u"←"- Curses.KeyRight -> u"→"- Curses.KeyEnd -> "End"- Curses.KeyHome -> "Home"- Curses.KeyBackspace -> "Backspace"- _ -> u[c]+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] ------------------------------------------------------------------------ -instance ModalElement HistModal where- drawModal sty swd st = flip fmap (histVisible st) \hist -> do- let wd = modalWidth swd- mtlen = maximum $ map (displayWidth . fst) hist- tlen = min (mtlen + 1) $ wd `div` 3- (wd,) $ flip map (zip (['0'..'9']++['a'..'z']) hist) \ (c, (time, (_, song))) ->- let tstr = toMaxWidth tlen $ P.replicate (tlen - displayWidth time) ' ' <> time- in Fast (toWidth wd $ " " <> P.singleton c <> " " <> tstr <> " " <> song) sty+histModal :: HistDisplay -> ModalMaker+histModal hist swd = do+ let wd = commonModalWidth swd+ mtlen = maximum $ 0 : map (displayWidth . fst) hist+ tlen = min (mtlen + 1) $ wd `div` 3+ (wd,) $ flip map (zip (['0'..'9']++['a'..'z']) hist) \ (c, (time, (_, song))) ->+ let tstr = toMaxWidth tlen $ P.replicate (tlen - displayWidth time) ' ' <> time+ in mconcat [" ", P.singleton c, " ", tstr, " ", song] ------------------------------------------------------------------------ -instance ModalElement ExitModal where- drawModal sty swd st = do- guard $ exitVisible st- let wd = modalWidth swd `min` 19- blank = Fast (toWidth wd "") sty- padl = P.replicate ((wd - 9) `div` 2) ' '- msg = toWidth wd $ padl <> "Exit (y)?"- pure (wd, [blank, Fast msg sty, blank])+exitModal :: ModalMaker+exitModal swd = (wd, ["", padl <> "Exit (y)?", ""]) where+ wd = commonModalWidth swd `min` 19+ padl = P.replicate ((wd - 9) `div` 2) ' ' ------------------------------------------------------------------------ -- | The time used and time left-instance Element PTimes where- draw DD { drawFrame=Just Frame {..}, drawSize=Size{sizeW=x} } =- PTimes $ FancyS $ map (, defaultSty)- if x - 4 < P.length elapsed- then [" "]- else [" ", elapsed]- ++ (guard (distance > 0) *> [gap, remaining])- where- elapsed = P.pack $ printf "%d:%02d" l_m l_s- remaining = P.pack $ printf "-%d:%02d" r_m r_s- (l_m,l_s) = toMS currentTime- (r_m,r_s) = toMS timeLeft- gap = spaces distance- distance = x - 4 - P.length elapsed - P.length remaining- toMS :: RealFrac a => a -> (Int, Int)- toMS = flip quotRem 60 . floor- draw _ = PTimes $ Fast (spaces 5) defaultSty+pTimes :: DrawData -> StringA+pTimes DD { drawFrame=Just Frame {..}, drawSize=Size{sizeW=x} } =+ FancyS $ map (, defaultSty)+ if x - 4 < P.length elapsed+ then [" "]+ else [" ", elapsed]+ ++ (guard (distance > 0) *> [gap, remaining])+ where+ elapsed = P.pack $ printf "%d:%02d" l_m l_s+ remaining = P.pack $ printf "-%d:%02d" r_m r_s+ (l_m, l_s) = toMS currentTime+ (r_m, r_s) = toMS timeLeft+ gap = spaces distance+ distance = x - 4 - P.length elapsed - P.length remaining+ toMS :: RealFrac a => a -> (Int, Int)+ toMS = flip quotRem 60 . floor+pTimes _ = Fast (spaces 5) defaultSty ------------------------------------------------------------------------ -- | A progress bar-instance Element ProgressBar where- draw dd@DD{drawSize=Size{sizeW=w}, drawState=st} = case drawFrame dd of- Nothing -> ProgressBar . FancyS $- [(" ", defaultSty), (spaces (w-4), bgs)]- where- (Style _ bg) = progress (config st)- bgs = Style bg bg- Just Frame {..} -> ProgressBar . 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+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 ------------------------------------------------------------------------ -- | Version info-instance Element PVersion where- draw _ = PVersion $ P.pack versinfo+pVersion :: ByteString+pVersion = P.pack versinfo -- | Uptime-instance Element PTime where- draw dd = PTime . uptime $ drawState dd+pTime :: DrawData -> ByteString+pTime = uptime . drawState -- | Play mode-instance Element PMode where- draw dd = PMode case status $ drawState dd of- Stopped -> "◼"- Paused -> "⏸"- Playing -> "▶"+pMode :: DrawData -> String+pMode dd = case status (drawState dd) of+ Stopped -> "◼"+ Paused -> "⏸"+ Playing -> "▶" -- | Loop, normal, or random-instance Element PMode2 where- draw dd = PMode2 case mode $ drawState dd of- Random -> "rand"- Loop -> "loop"- Once -> "once"- Single -> "sing"+pMode2 :: DrawData -> String+pMode2 dd = case mode (drawState dd) of+ Random -> "rand"+ Loop -> "loop"+ Once -> "once"+ Single -> "sing" ------------------------------------------------------------------------ -instance Element PlayModes where- draw dd = PlayModes $ m ++ ' ' : m'- where- PMode m = draw dd- PMode2 m' = draw dd--instance Element PlayInfo where- draw dd = PlayInfo $ mconcat [- -- TODO pregenerate as template- spaces (P.length numd - P.length curd)- , curd- , "/", numd- , " dir"- , onPlural (snd . bounds $ folders st) "" "s"- , " "- , spaces (P.length numf - P.length curf)- , curf- , "/", numf- , " file"- , onPlural (size st) "" "s"- ]- where- st = drawState dd- tobs = P.pack . show- onPlural 1 s _ = s- onPlural _ _ p = p- curf = tobs $ 1 + cursor st- numf = tobs $ size st- mydir = fdir $ music st ! cursor st- curd = tobs $ 1 + mydir- numd = tobs $ 1 + snd (bounds $ folders st)+-- | The two play-mode glyphs (e.g. "▶ rand") rendered together.+playModes :: DrawData -> String+playModes dd = pMode dd ++ ' ' : pMode2 dd -instance Element PlayTitle where- draw dd =- PlayTitle $ FancyS $ map (,hl)- if gap >= 2- then [mconcat [" ", inf, spaces gapl], modesBS,- mconcat [spaces gapr, time, " ", ver, " "]]- else let gap' = x - modlen; gapl' = gap' `div` 2- in if gap' >= 2- then [spaces gapl', modesBS, spaces $ gap' - gapl']- else [" ", u $ take (x-2) modes, " "]- where- PlayInfo inf = draw dd- PTime time = draw dd- PlayModes modes = draw dd- PVersion ver = draw dd- modesBS = u modes+-- | "x/n dir(s) y/m file(s)" cursor position read-out.+playInfo :: DrawData -> ByteString+playInfo dd = mconcat+ -- TODO pregenerate as template+ [ spaces (P.length numd - P.length curd)+ , curd, "/", numd, " dir", onPlural (snd . bounds $ folders st) "" "s"+ , " "+ , spaces (P.length numf - P.length curf)+ , curf, "/", numf, " file", onPlural (size st) "" "s"+ ]+ where+ st = drawState dd+ tobs = P.pack . show+ onPlural 1 s _ = s+ onPlural _ _ p = p+ curf = tobs $ 1 + cursor st+ numf = tobs $ size st+ mydir = fdir $ music st ! cursor st+ curd = tobs $ 1 + mydir+ numd = tobs $ 1 + snd (bounds $ folders st) - x = sizeW $ drawSize dd- lsize = 1 + P.length inf- rsize = 2 + P.length time + P.length ver- side = (x - modlen) `div` 2- gap = x - modlen - lsize - rsize- gapl = 1 `max` ((side - lsize) `min` gap)- gapr = 1 `max` (gap - gapl)- modlen = 6 -- length modes- hl = titlebar . config $ drawState dd+-- | The top title bar: cursor position + play modes + uptime + version.+playTitle :: DrawData -> StringA+playTitle dd =+ FancyS $ map (, hl)+ if gap >= 2+ then [mconcat [" ", inf, spaces gapl], modesBS,+ mconcat [spaces gapr, time, " ", ver, " "]]+ else let gap' = x - modlen; gapl' = gap' `div` 2+ in if gap' >= 2+ then [spaces gapl', modesBS, spaces $ gap' - gapl']+ else [" ", u $ take (x-2) modes, " "]+ where+ inf = playInfo dd+ time = pTime dd+ modes = playModes dd+ ver = pVersion+ modesBS = u modes --- | Playlist-instance Element PlayList where- draw dd@DD{ drawSize=Size y x, drawPos=Pos{posY=o}, drawState=st } =- PlayList $- title- : list- ++ replicate (height - length list - 2) (Fast P.empty defaultSty)- ++ [minibuffer st]- where- PlayTitle title = draw dd+ x = sizeW $ drawSize dd+ lsize = 1 + P.length inf+ rsize = 2 + P.length time + P.length ver+ side = (x - modlen) `div` 2+ gap = x - modlen - lsize - rsize+ gapl = 1 `max` ((side - lsize) `min` (gap - 1))+ gapr = gap - gapl+ modlen = 6 -- length modes+ hl = titlebar . config $ drawState dd - songs = music st- this = current st- curr = cursor st- height = y - o+-- | 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+ -- 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)+ playing = let top = screens * buflen+ bot = (screens + 1) * buflen+ in if this >= top && this < bot+ then this - top -- playing song is visible+ else (-1) - -- visible slice of the playlist- visible = slice off (off + buflen) songs- where off = screens * buflen+ -- visible slice of the playlist+ visible = slice off (off + buflen) songs+ where off = screens * buflen - -- TODO rewrite as fold- 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+ 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 - list = [ drawIt . color $ n | n <- zip visible' [0..] ]+ list = [ drawIt . color $ n | n <- zip visible' [0..] ] - indent = (round $ (0.334 :: Float) * fromIntegral x) :: Int+ indent = (round $ (0.334 :: Float) * fromIntegral x) :: Int - color :: ((Maybe Int, ByteString), Int)- -> (Maybe Int, Style, [ByteString])- color ((m,s),i)- | i == select && i == playing = f sty3- | i == select = f sty2- | i == playing = f sty1- | otherwise = (m, defaultSty, [s])- where- f sty = (m, sty,- [s, spaces (x - indent - 1 - displayWidth s)])+ color :: ((Maybe Int, ByteString), Int)+ -> (Maybe Int, Style, [ByteString])+ color ((m, s), i)+ | i == select && i == playing = f sty3+ | i == select = f sty2+ | i == playing = f sty1+ | otherwise = (m, defaultSty, [s])+ where+ f sty = (m, sty,+ [s, spaces (x - indent - 1 - displayWidth s)]) - sty1 = selected . config $ st- sty2 = cursors . config $ st- sty3 = combined . config $ st+ sty1 = selected . config $ st+ sty2 = cursors . config $ st+ sty3 = combined . config $ st - drawIt :: (Maybe Int, Style, [ByteString]) -> StringA- drawIt (Nothing, sty, v) =- FancyS $ map (, sty) $ spaces (1 + indent) : v+ drawIt :: (Maybe Int, Style, [ByteString]) -> StringA+ 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- where- sty' = if sty == sty2 || sty == sty3 then sty2 else sty1- d = toMaxWidth (indent - 1) $ basenameP- $ case size st of- 0 -> "(empty)"- _ -> dname $ folders st ! i+ drawIt (Just i, sty, v) = FancyS+ $ (d, sty')+ : (spaces (indent + 1 - displayWidth d), sty')+ : map (, sty) v+ where+ sty' = if sty == sty2 || sty == sty3 then sty2 else sty1+ d = toMaxWidth (indent - 1) $ takeFileName+ $ case size st of+ 0 -> "(empty)"+ _ -> dname $ folders st ! i ------ | Decode the list of current tracks----printPlayList :: PlayList -> [StringA]-printPlayList (PlayList s) = s-{-# INLINE printPlayList #-}- ------------------------------------------------------------------------ spaces :: Int -> ByteString spaces = flip P.replicate ' ' --------------------------------------------------------------------------- -- | Now write out just the clock line--- Speed things up a bit, just use read State.--- redrawJustClock :: Draw redrawJustClock = Draw $ discardErrors do- st <- getsHS id- let fr = clock st- (h, w) <- screenSize- let sz = Size h w- let (ProgressBar bar) = draw $ DD sz undefined st fr :: ProgressBar- (PTimes times) = {-# SCC "redrawJustClock.times" #-}- draw $ DD sz undefined st fr :: PTimes- Curses.wMove Curses.stdScr 1 0 -- hardcoded!- drawLine w bar- Curses.wMove Curses.stdScr 2 0 -- hardcoded!- drawLine w times- when (h<45) $ renderModals st sz -- small screen modals paint over clock+ 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+ when (h < 45) $ renderModals st (Size h w) -- small screen modals paint over clock ------------------------------------------------------------------------------ work for drawing help. draw the help screen if it is up----renderModal :: forall me. ModalElement me => HState -> Size -> IO ()-renderModal st (Size h w) = do- for_ (drawModal @me (modals $ config st) w st) \(mw, modal') -> do- let hoffset = max 0 $ (w - mw) `div` 2- mlines = min h $ length modal'- voffset = (h - mlines) `div` 2- Curses.wMove Curses.stdScr voffset hoffset- for_ (take mlines modal') \t -> do- drawLine w t- (y', _) <- Curses.getYX Curses.stdScr- Curses.wMove Curses.stdScr (y'+1) hoffset+-- | General modal renderer.+renderModal :: HState -> Size -> ModalMaker -> IO ()+renderModal st (Size h w) mkr = do+ let (mw, modal') = mkr w+ hoffset = max 0 $ (w - mw) `div` 2+ mlines = min h $ length modal'+ voffset = (h - mlines) `div` 2+ sty = modals $ config st+ Curses.wMove Curses.stdScr voffset hoffset+ for_ (take mlines modal') \t -> do+ drawLine $ Fast (toWidth mw t) sty+ (y', _) <- Curses.getYX Curses.stdScr+ Curses.wMove Curses.stdScr (y'+1) hoffset +-- | Choose modal to render based on state. renderModals :: HState -> Size -> IO ()-renderModals s sz = do- renderModal @HelpModal s sz- renderModal @HistModal s sz- renderModal @ExitModal s sz+renderModals st sz =+ whenJust (modal st) $ renderModal st sz . \case+ HelpModal h -> helpModal h+ HistModal h -> histModal h+ ExitModal -> exitModal ------------------------------------------------------------------------ -- -- | Draw the screen -- redraw :: Draw-redraw = Draw $ discardErrors do- -- linux ncurses, in particular, seems to complain a lot. this is an easy solution- s <- getsHS id -- another refresh could be triggered?- let f = clock s- (h, w) <- screenSize- let sz = Size h w+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)) - let a = let x = printPlayScreen (draw $ DD sz (Pos 0 0) s f :: PlayScreen)- y = printPlayList (draw $ DD sz (Pos (length x) 0) s f :: PlayList)- in x ++ y+ setXterm st - when (xterm s) $ setXterm s- - gotoTop- for_ (take (h-1) (init a)) \t -> do- drawLine w t- (y, x) <- Curses.getYX Curses.stdScr- fillLine- maybeLineDown t h y x- renderModals s sz+ gotoTop+ for_ (take (h-1) (init a)) \t -> do+ drawLine t+ (y, x) <- Curses.getYX Curses.stdScr+ fillLine+ maybeLineDown t h y x+ renderModals st sz - -- minibuffer- Curses.wMove Curses.stdScr (h-1) 0- fillLine - Curses.wMove Curses.stdScr (h-1) 0- drawLine (w-1) (last a)- when (miniFocused s) do -- a fake cursor- drawLine 1 (Fast (spaces 1) (blockcursor . config $ s ))+ -- minibuffer+ Curses.wMove Curses.stdScr (h-1) 0+ 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 ------------------------------------------------------------------------ -- -- | Draw a coloured (or not) string to the screen ---drawLine :: Int -> StringA -> IO ()-drawLine _ (Fast ps sty) = drawSegment ps sty-drawLine _ (FancyS ls) = traverse_ (uncurry drawSegment) ls+drawLine :: StringA -> IO ()+drawLine (Fast ps sty) = drawSegment ps sty+drawLine (FancyS ls) = traverse_ (uncurry drawSegment) ls -- | Write a single styled UTF-8 segment. Safe because C only reads the bytes. drawSegment :: ByteString -> Style -> IO ()@@ -666,9 +564,6 @@ in [unsafeAt arr n | n <- [max a i .. min b j] ] {-# INLINE slice #-} --- isAscii :: ByteString -> Bool--- isAscii = P.all (<'\128')- ------------------------------------------------------------------------ --@@ -684,14 +579,11 @@ ------------------------------------------------------------------------ --- set xterm title (should have an instance Element)--- Don't need to do this on each refresh...+-- 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 -> case size s of- 0 -> ["hmp3"]- _ -> [fbase $ music s ! current s]+ Nothing -> [fbase $ music s ! current s] Just ti -> id3artist ti : if P.null (id3title ti) then []
app/Main.hs view
@@ -9,6 +9,7 @@ import Core (start, shutdown, Options(..)) import qualified Config+import Keymap (keyLoop) import Tree (buildTree, isEmpty) import System.IO (hPrint, stderr)@@ -71,9 +72,12 @@ main :: IO () main = do (opts, args) <- customExecParser (prefs showHelpOnEmpty) parserInfo- initSignals tree <- buildTree args- if isEmpty tree- then putStrLn "Error: No music files found." *> exitFailure- else start opts tree -- never returns+ when (isEmpty tree) $+ errorWithoutStackTrace "Error: No music files found."+ initSignals+ err <- either id absurd <$> try @SomeException do+ start opts tree+ keyLoop+ shutdown $ Just $ "Error: " ++ show err
hmp3-ng.cabal view
@@ -1,23 +1,23 @@ cabal-version: 3.0+name: hmp3-ng+version: 2.18.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+ passing file and directory names on the command line. 'h' displays+ help. -name: hmp3-ng-version: 2.18.0-synopsis: A 2019 fork of an ncurses mp3 player written in Haskell-description: An mp3 player with a curses frontend. Playlists are populated by- passing file and directory names on the command line. 'h' displays- help.-category: Sound-homepage: https://github.com/galenhuntington/hmp3-ng#readme-bug-reports: https://github.com/galenhuntington/hmp3-ng/issues-author: Don Stewart, Galen Huntington-maintainer: Galen Huntington-license: GPL-2.0-or-later-license-file: LICENSE-build-type: Simple-extra-source-files:- Keymap.hs-boot+category: Sound+homepage: https://github.com/galenhuntington/hmp3-ng#readme+bug-reports: https://github.com/galenhuntington/hmp3-ng/issues+author: Don Stewart, Galen Huntington+maintainer: Galen Huntington+license: GPL-2.0-or-later+license-file: LICENSE+build-type: Simple+ extra-doc-files:- README.md+ README.md source-repository head type: git@@ -26,57 +26,69 @@ common opts default-language: Haskell2010 default-extensions:- BangPatterns- BlockArguments- OverloadedStrings- ScopedTypeVariables- TypeApplications- DerivingStrategies- RecordWildCards- LambdaCase- MultiWayIf- StandaloneDeriving- NumericUnderscores- NamedFieldPuns- ghc-options: -Wall -funbox-strict-fields+ BlockArguments+ MultiWayIf+ OverloadedStrings+ RecordWildCards+ -- In GHC2024+ DerivingStrategies+ LambdaCase+ -- In GHC2021 (soon!)+ BangPatterns+ GeneralizedNewtypeDeriving+ NamedFieldPuns+ NumericUnderscores+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications + ghc-options:+ -Wall+ -funbox-strict-fields+ library import: opts hs-source-dirs: ./ exposed-modules:- Base- Config- Core- FastIO- Keymap- Lexer- State- Style- Syntax- Tree- UI- Width+ Base+ Config+ Core+ Keyboard+ Keymap+ Lexer+ State+ Style+ Syntax+ Tree+ UI+ Width+ other-modules:- Paths_hmp3_ng+ Paths_hmp3_ng+ autogen-modules:- Paths_hmp3_ng+ Paths_hmp3_ng+ pkgconfig-depends:- ncursesw+ ncursesw+ build-depends:- , array- , base ==4.*- , bytestring >=0.10- , clock- , containers- , directory >=1.3.7.0- , filepath- , hscurses- , mtl- , pcre-light >=0.3- , process- , random- , unix >=2.7- , utf8-string+ array,+ base >=4.15 && <5,+ bytestring >=0.10,+ clock,+ containers,+ directory >=1.3.7.0,+ filepath,+ hscurses,+ mtl,+ pcre-light >=0.3,+ posix-paths,+ process,+ random,+ unix >=2.7,+ utf8-string, executable hmp3 import: opts@@ -84,12 +96,12 @@ hs-source-dirs: app ghc-options: -threaded build-depends:- , base- , bytestring- , hmp3-ng- , optparse-applicative- , unix- , utf8-string+ base,+ bytestring,+ hmp3-ng,+ optparse-applicative,+ unix,+ utf8-string, test-suite test import: opts@@ -97,19 +109,19 @@ main-is: Main.hs hs-source-dirs: test other-modules:- ConfigSpec- CoreSpec- FastIOSpec- LexerSpec- StyleSpec- TreeSpec- WidthSpec+ ConfigSpec+ CoreSpec+ LexerSpec+ StyleSpec+ TreeSpec+ WidthSpec+ build-depends:- , base- , bytestring- , clock- , hmp3-ng- , tasty >=1.4- , tasty-hunit >=0.10- , utf8-string+ base,+ bytestring,+ clock,+ hmp3-ng,+ tasty >=1.4,+ tasty-hunit >=0.10,+ utf8-string,
− test/FastIOSpec.hs
@@ -1,42 +0,0 @@-module FastIOSpec (tests) where--import Test.Tasty-import Test.Tasty.HUnit--import FastIO (basenameP, dirnameP, packedFileNameEndClean, trim)--tests :: TestTree-tests = testGroup "FastIO"- [ testGroup "basenameP"- [ testCase "no slash" $ basenameP "foo" @?= "foo"- , testCase "single dir" $ basenameP "foo/bar" @?= "bar"- , testCase "leading slash" $ basenameP "/foo" @?= "foo"- , testCase "nested" $ basenameP "a/b/c/d.mp3" @?= "d.mp3"- , testCase "trailing slash" $ basenameP "foo/" @?= ""- , testCase "empty" $ basenameP "" @?= ""- ]- , testGroup "dirnameP"- [ testCase "no slash" $ dirnameP "foo" @?= "."- , testCase "single dir" $ dirnameP "foo/bar" @?= "foo"- , testCase "leading slash" $ dirnameP "/foo" @?= ""- , testCase "nested" $ dirnameP "a/b/c/d.mp3" @?= "a/b/c"- ]- , testGroup "trim"- [ testCase "no whitespace" $ trim "foo" @?= "foo"- , testCase "leading spaces" $ trim " foo" @?= "foo"- , testCase "trailing spaces" $ trim "foo " @?= "foo"- , testCase "both" $ trim " foo " @?= "foo"- , testCase "internal preserved" $ trim " foo bar " @?= "foo bar"- , testCase "tabs and newlines" $ trim "\t foo \n" @?= "foo"- , testCase "whitespace only" $ trim " " @?= ""- , testCase "empty" $ trim "" @?= ""- ]- , testGroup "packedFileNameEndClean"- [ testCase "no trailing" $ packedFileNameEndClean "foo" @?= "foo"- , testCase "trailing slash" $ packedFileNameEndClean "foo/" @?= "foo"- , testCase "trailing backslash" $ packedFileNameEndClean "foo\\" @?= "foo"- , testCase "multiple trailing" $ packedFileNameEndClean "foo/\\/" @?= "foo"- , testCase "internal preserved" $ packedFileNameEndClean "a/b/c/" @?= "a/b/c"- , testCase "empty" $ packedFileNameEndClean "" @?= ""- ]- ]
test/LexerSpec.hs view
@@ -5,55 +5,61 @@ import qualified Data.ByteString.Char8 as P -import Lexer (doP, doF, doS, doI)+import Lexer (mpgParser) import Syntax +-- These exercise the helpers doX, 'trim', and 'normalise'. tests :: TestTree-tests = testGroup "Lexer"- [ testGroup "doP (status messages)"- [ testCase "0 is Stopped" $ doP "0" @?= S Stopped- , testCase "1 is Paused" $ doP "1" @?= S Paused- , testCase "2 is Playing" $ doP "2" @?= S Playing- , testCase "3 is Playing" $ doP "3" @?= S Playing- , testCase "empty is Playing" $ doP "" @?= S Playing- , testCase "garbage is Playing" $ doP "xyz" @?= S Playing+tests = testGroup "Lexer.mpgParser"+ [ testGroup "status (@P)"+ [ tc "@P 0" $ Right (S Stopped)+ , tc "@P 1" $ Right (S Paused)+ , tc "@P 2" $ Right (S Playing)+ , tc "@P 3" $ Left Nothing -- end-of-song marker: ignored (no double play)+ , tc "@P 9" $ Left Nothing -- unknown code+ , tc "@P " $ Left Nothing -- no payload ]- , testGroup "doF (frame messages)"- [ testCase "all four fields parse" $- doF "123 456 12.34 56.78" @?= R (Frame 123 456 12.34 56.78)- , testCase "negative timeLeft is clamped to zero" $- doF "0 0 0.00 -1.00" @?= R (Frame 0 0 0.00 0)+ , testGroup "frame (@F)"+ [ tc "@F 123 456 12.34 56.78" $ Right (R (Frame 123 456 12.34 56.78))+ , tc "@F 0 0 0.00 -1.00" $ Right (R (Frame 0 0 0.00 0)) -- timeLeft clamped+ , tc "@F 1 2 3.00" $ Left Nothing -- too few fields+ , tc "@F a b c d" $ Left Nothing -- non-numeric ]- , testGroup "doS (info messages)"- [ testCase "userinfo combines version, bitrate, kHz" $- doS "1.0 1 44100 stereo 0 0 2 0 0 0 128 0"- @?= I (Info "mpeg 1.0 128kbit/s 44kHz")+ , testGroup "stream info (@S)"+ [ tc "@S 1.0 1 44100 stereo 0 0 2 0 0 0 128 0"+ $ Right (I (Info "mpeg 1.0 128kbit/s 44kHz"))+ , tc "@S 1.0 1 44100" $ Left Nothing -- too few fields ]- , testGroup "doI (track info / id3)"- [ testCase "non-id3 input becomes Left filename" $- doI "song.mp3"- @?= F (File (Left "song.mp3"))- , testCase "non-id3 input is trimmed" $- doI " song.mp3 "- @?= F (File (Left "song.mp3"))- , testCase "id3 with title only" $- doI ("ID3:" <> field30 "Title")- @?= F (File (Right (Id3 "Title" "" "" "Title")))- , testCase "id3 with title and artist" $- doI ("ID3:" <> field30 "Title" <> field30 "Artist")- @?= F (File (Right (Id3 "Title" "Artist" "" "Artist : Title")))- , testCase "id3 with title, artist, and album" $- doI ("ID3:" <> field30 "Title" <> field30 "Artist" <> field30 "Album")- @?= F (File (Right (Id3 "Title" "Artist" "Album" "Artist : Album : Title")))- , testCase "id3 with empty title falls back to Left of trimmed input" $- -- mpg123 sometimes returns ID3 records with a blank title; rather than- -- present an empty track name, the parser exposes the raw line.- doI ("ID3:" <> field30 "" <> field30 "Artist")- @?= F (File (Left ("ID3:" <> P.replicate 30 ' ' <> "Artist")))+ , testGroup "id3 (@I)" (let s = "n\195\182rmalise" in+ [ tcId3 ["Title"]+ $ Right (F (Id3 "Title" "" "" "Title"))+ , tcId3 ["Title", "Artist"]+ $ Right (F (Id3 "Title" "Artist" "" "Artist : Title"))+ , tcId3 [" Title", " Artist"]+ $ Right (F (Id3 "Title" "Artist" "" "Artist : Title"))+ , tcId3 ["Title", "Artist", "Album"]+ $ Right (F (Id3 "Title" "Artist" "Album" "Artist : Album : Title"))+ , tcId3 ["", "Artist"] $ Left Nothing -- blank title: skipped+ , tc "@I song.mp3" $ Left Nothing -- non-ID3 @I: don't overwrite+ , tc "@I {" $ Left Nothing -- grouping marker: ignored+ , tcId3 ["nörmalise"] $ Right (F (Id3 s "" "" s))+ , tcId3 [s] $ Right (F (Id3 s "" "" s))+ ])+ , testGroup "tagline, errors, junk"+ [ tc "@R a tagline" $ Right (T Tag)+ , tc "@E some failure" $ Left (Just "some failure")+ , tc "garbage" $ Left Nothing -- no @ prefix+ , tc "@F" $ Left Nothing -- no space after code+ , tc "@" $ Left Nothing+ , tc "" $ Left Nothing ] ]+ where+ tc line = tc' (show line) line+ tc' tag line expected = testCase tag $ mpgParser line @?= expected+ tcId3 fields = tc' (show fields) (id3 fields) --- Pad/truncate a ByteString to exactly 30 characters with trailing spaces,--- matching the fixed-width field convention used by mpg123 ID3 output.-field30 :: P.ByteString -> P.ByteString-field30 b = P.take 30 (b <> P.replicate 30 ' ')+-- | Build an "@I ID3:" line from fixed-width 30-char fields, as mpg123 emits.+id3 :: [P.ByteString] -> P.ByteString+id3 fields = "@I ID3:" <> mconcat [ P.take 30 (f <> P.replicate 30 ' ') | f <- fields ]+
test/Main.hs view
@@ -4,7 +4,6 @@ import qualified ConfigSpec import qualified CoreSpec-import qualified FastIOSpec import qualified LexerSpec import qualified StyleSpec import qualified TreeSpec@@ -14,7 +13,6 @@ main = defaultMain $ testGroup "hmp3-ng" [ ConfigSpec.tests , CoreSpec.tests- , FastIOSpec.tests , LexerSpec.tests , StyleSpec.tests , TreeSpec.tests