hmp3-ng 2.7.3.1 → 2.9.3
raw patch · 11 files changed
+197/−262 lines, 11 filesdep +randomdep −mersenne-random
Dependencies added: random
Dependencies removed: mersenne-random
Files
- Core.hs +44/−43
- FastIO.hs +3/−0
- Keymap.hs +8/−3
- Lexer.hs +30/−34
- README.md +27/−17
- State.hs +2/−5
- Style.hs +3/−3
- Syntax.hs +10/−7
- UI.hs +65/−60
- Utils.hs +1/−86
- hmp3-ng.cabal +4/−4
Core.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, AllowAmbiguousTypes #-} -- -- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons@@ -27,7 +27,8 @@ start, shutdown, seekLeft, seekRight, up, down, pause, nextMode, playNext, playPrev,- quit, putmsg, clrmsg, toggleHelp, play, playCur, jumpToPlaying, jump, {-, add-}+ quit, putmsg, clrmsg, toggleHelp, play, playCur,+ jumpToPlaying, jump, jumpRel, upPage, downPage, seekStart, blacklist,@@ -44,11 +45,10 @@ import State import Style import Utils-import FastIO (send, FiltHandle(..))+import FastIO (send, FiltHandle(..), newFiltHandle) import Tree hiding (File,Dir) import qualified Tree (File,Dir) import qualified UI-import Data.IORef import Text.Regex.PCRE.Light import {-# SOURCE #-} Keymap (keymap)@@ -57,15 +57,15 @@ import Data.Array ((!), bounds, Array) import Data.Maybe (isJust,fromJust)-import Control.Monad (liftM, when, msum)+import Control.Monad (liftM, when, msum, forever) import System.Directory (doesFileExist,findExecutable) import System.Environment (getEnv) import System.Exit (ExitCode(ExitSuccess),exitWith) import System.IO (hPutStrLn, hGetLine, stderr, hFlush) import System.IO.Unsafe (unsafeInterleaveIO)-import System.Process (waitForProcess)+import System.Process import System.Clock (getTime, Clock(..))-import System.Random.Mersenne+import System.Random (randomIO) import System.Posix.Process (exitImmediately) import System.Posix.User (getUserEntryForID, getRealUserID, homeDirectory)@@ -73,7 +73,6 @@ import Control.Concurrent import Control.Exception -import GHC.IO.Handle.FD (fdToHandle) mp3Tool :: String mp3Tool =@@ -134,25 +133,24 @@ ------------------------------------------------------------------------ -- | Uniform loop and thread handler (subtle, and requires exitImmediately)-forever :: IO () -> IO ()-forever fn = catch (repeatM_ fn) handler+runForever :: IO () -> IO ()+runForever fn = catch (forever fn) handler where handler :: SomeException -> IO () handler e = when (not.exitTime $ e) $- (warnA . show) e >> (forever fn) -- reopen the catch+ (warnA . show) e >> runForever fn -- reopen the catch -- | Generic handler+-- I don't know why these are ignored, but preserving old logic. -- For profiling, make sure to return True for anything: exitTime :: SomeException -> Bool--- TODO make this work with new exception hierarchy-{--exitTime e | isJust . ioErrors $ e = False -- ignore- | isJust . errorCalls $ e = False -- ignore- | isJust . userErrors $ e = False -- ignore- | otherwise = True--}-exitTime _ = True+exitTime e | is @IOException e = False -- ignore+ | is @ErrorCall 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 ------------------------------------------------------------------------ @@ -163,27 +161,25 @@ -- For example, if we can't start it two times in a row, perhaps give up? -- mpgLoop :: IO ()-mpgLoop = forever $ do+mpgLoop = runForever $ do mmpg <- findExecutable mp3Tool case mmpg of Nothing -> quit (Just $ "Cannot find " ++ mp3Tool ++ " in path") Just mpg321 -> do -- if we're never able to start mpg321, do something sensible- mv <- catch (popen mpg321 ["-R","-"] >>= return . Just)+ -- TODO no need for this Maybe unpacking, just catch and rerun loop+ mv <- catch (pure <$> runInteractiveProcess mpg321 ["-R","-"] Nothing Nothing) (\ (e :: SomeException) -> do warnA ("Unable to start " ++ mp3Tool ++ ": " ++ show e) return Nothing) case mv of Nothing -> threadDelay (1000 * 500) >> mpgLoop- Just (r,w,e,pid) -> do+ Just (hw, r, e, pid) -> do - hw <- fdToHandle (fromIntegral w) -- so we can use Haskell IO- ew <- FiltHandle <$> fdToHandle (fromIntegral e) <*> newIORef 0- filep <- FiltHandle <$> fdToHandle (fromIntegral r) <*> newIORef 0 mhw <- newMVar hw- mew <- newMVar ew- mfilep <- newMVar filep+ mew <- newMVar =<< newFiltHandle e+ mfilep <- newMVar =<< newFiltHandle r modifyST $ \st -> st { mp3pid = Just pid@@ -194,9 +190,9 @@ , info = Nothing , id3 = Nothing } - catch (waitForProcess (pid2phdl pid)) (\ (_ :: SomeException) -> return ExitSuccess)+ catch (waitForProcess pid) (\ (_ :: SomeException) -> return ExitSuccess) stop <- getsST doNotResuscitate- when (stop) $ exitWith ExitSuccess+ when stop $ exitWith ExitSuccess warnA $ "Restarting " ++ mpg321 ++ " ..." ------------------------------------------------------------------------@@ -206,13 +202,13 @@ refreshLoop :: IO () refreshLoop = do mvar <- getsST modified- forever $ takeMVar mvar >> UI.refresh+ runForever $ takeMVar mvar >> UI.refresh ------------------------------------------------------------------------ -- | The clock ticks once per minute, but check more often in case of drift. uptimeLoop :: IO ()-uptimeLoop = forever $ do+uptimeLoop = runForever $ do threadDelay delay now <- getTime Monotonic modifyST $ \st -> st { uptime = drawUptime (boottime st) now }@@ -223,7 +219,7 @@ -- | Once each half second, wake up a and redraw the clock clockLoop :: IO ()-clockLoop = forever $ threadDelay delay >> UI.refreshClock+clockLoop = runForever $ threadDelay delay >> UI.refreshClock where delay = 500 * 1000 -- 0.5 second @@ -231,7 +227,7 @@ -- | Handle, and display errors produced by mpg321 errorLoop :: IO ()-errorLoop = forever $ do+errorLoop = runForever $ do s <- getsST errh >>= readMVar >>= hGetLine . filtHandle if s == "No default libao driver available." then quit $ Just $ s ++ " Perhaps another instance of hmp3 is running?"@@ -244,19 +240,20 @@ -- take that chance to exit. -- mpgInput :: (HState -> MVar FiltHandle) -> IO ()-mpgInput field = forever $ do+mpgInput field = runForever $ do mvar <- getsST field fp <- readMVar mvar res <- parser fp case res of- Right m -> handleMsg m- Left e -> (warnA.show) e -- error from pipe+ Right m -> handleMsg m+ Left (Just e) -> (warnA.show) e+ _ -> pure () ------------------------------------------------------------------------ -- | The main thread: handle keystrokes fed to us by curses run :: IO ()-run = forever $ sequence_ . keymap =<< getKeys+run = runForever $ sequence_ . keymap =<< getKeys where getKeys = unsafeInterleaveIO $ do c <- UI.getKey@@ -276,7 +273,7 @@ Just pid -> do h <- readMVar (writeh st) send h Quit -- ask politely- waitForProcess $ pid2phdl pid+ waitForProcess pid return ()) `finally`@@ -362,6 +359,12 @@ jump :: Int -> IO () jump i = modifySTM $ flip jumpTo (const i) +-- | Jump to relative place, 0 to 1.+jumpRel :: Float -> IO ()+jumpRel r | r < 0 || r >= 1 = return ()+ | True = modifySTM \st ->+ pure st { cursor = floor $ fromIntegral (size st) * r }+ -- | Generic jump jumpTo :: HState -> (Int -> Int) -> IO HState jumpTo st fn = do@@ -377,8 +380,7 @@ play = modifySTM $ \st -> if current st == cursor st then do- let g = randomGen st- n' <- random g :: IO Int+ n' <- randomIO let n = abs n' `mod` (size st -1) playAtN st (const n) else@@ -398,9 +400,8 @@ -- | Play a random song playRandom :: IO () playRandom = modifySTM $ \st -> do- let g = randomGen st- n' <- random g :: IO Int- let n = abs n' `mod` (size st -1)+ n' <- randomIO+ let n = abs n' `mod` (size st - 1) playAtN st (const n) -- | Play the song before the current song, if we're not at the beginning
FastIO.hs view
@@ -83,6 +83,9 @@ 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 P.ByteString
Keymap.hs view
@@ -159,9 +159,11 @@ ,("Page up", [unkey KeyPPage], upPage) ,("Jump to start of list",- [unkey KeyHome,'1'], jump 0)+ [unkey KeyHome,'0'], jump 0) ,("Jump to end of list", [unkey KeyEnd,'G'], jump maxBound)+ ,("Jump to 10%, 20%, 30%, etc., point",+ ['1','2','3'], undefined) -- overridden below ,("Seek left within song", [unkey KeyLeft], seekLeft) ,("Seek right within song",@@ -200,6 +202,9 @@ [unkey KeyBackspace], seekStart) ] +innerTable :: [(Char, IO ())]+innerTable = [(c, jumpRel i) | (i, c) <- zip [0.1, 0.2 ..] ['1'..'9']]+ extraTable :: [(P.ByteString, [Char])] extraTable = [("Search for file matching regex", ['/']) ,("Search backwards for file", ['?'])@@ -210,7 +215,7 @@ helpIsVisible = getsST helpVisible 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 ] ++ innerTable keys :: [Char]-keys = concat [ cs | (_,cs,_) <- keyTable ]+keys = concat [ cs | (_,cs,_) <- keyTable ] ++ map fst innerTable
Lexer.hs view
@@ -28,6 +28,7 @@ import Data.Maybe (fromJust) import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.UTF8 as UTF8 import Control.Monad.Except ------------------------------------------------------------------------@@ -35,6 +36,9 @@ pSafeHead :: P.ByteString -> Char pSafeHead s = if P.null s then ' ' else P.head s +readPS :: P.ByteString -> Int+readPS = fst . fromJust . P.readInt+ doP :: P.ByteString -> Msg doP s = S $! case pSafeHead s of '0' -> Stopped@@ -47,21 +51,13 @@ -- Frame decoding status updates (once per frame). doF :: P.ByteString -> Msg doF s = R $ Frame {- currentFrame = readPS (fs !! 0)- , framesLeft = readPS (fs !! 1)- , currentTime = f 2- , timeLeft = f 3+ currentFrame = readPS f0+ , framesLeft = readPS f1+ , currentTime = read . P.unpack $ f2+ , timeLeft = max 0 . read . P.unpack $ f3 } where-- fs = P.split ' ' $ s- f n = case P.split '.' (fs !! n) of { [x,y] ->- case readPS x of { rx ->- case readPS y of { ry -> (rx,ry) }}- ; _ -> error "doF.f" }--readPS :: P.ByteString -> Int-readPS = fst . fromJust . P.readInt+ f0 : f1 : f2 : f3 : _ = P.split ' ' s -- Outputs information about the mp3 file after loading. doS :: P.ByteString -> Msg@@ -104,7 +100,7 @@ where -- a default id3 :: Id3- id3 = Id3 P.empty P.empty P.empty P.empty+ id3 = Id3 "" "" "" "" -- break the ID3 string up splitUp :: P.ByteString -> [P.ByteString]@@ -130,32 +126,32 @@ , id3artist = normalise $! ls !! 1 , id3album = normalise $! ls !! 2 } - in j { id3str = (id3artist j)- `maybeJoin`- (id3album j)- `maybeJoin`- (id3title j) }-- maybeJoin t f = if P.null f then t `P.append` P.empty else t `gap` f+ in j { id3str =+ id3artist j `maybeJoin` id3album j `maybeJoin` id3title j } - gap x y = P.concat [ x, " : ", y ]+ maybeJoin t f | P.null f = t+ | True = mconcat [t, " : ", f] - normalise = P.dropWhile isSpace . dropSpaceEnd+ -- strip spaces, and decide if UTF-8 or ISO-8859-1+ normalise :: P.ByteString -> P.ByteString+ normalise raw =+ let bs = P.dropWhile isSpace . dropSpaceEnd $ raw+ in if any (== UTF8.replacement_char) $ UTF8.toString bs+ then UTF8.fromString $ P.unpack bs+ else bs ------------------------------------------------------------------------ -parser :: FiltHandle -> IO (Either String Msg)-parser h = runExceptT loop where- loop = do+parser :: FiltHandle -> IO (Either (Maybe String) Msg)+parser h = runExceptT do x <- lift $ getPacket h- let -- badPacket :: ExceptT String IO a -- MonoLocalBinds...- badPacket = throwError $ "Bad packet: " ++ show (P.unpack x)- -- worth notifying about? most are just newlines in the ID data+ -- bad packets are generally just \n in ID3 (and not of interest anyway)+ let skip = throwError Nothing - when (P.length x < 3) $ void badPacket+ when (P.length x < 3) skip let (pre, m) = P.splitAt 3 x at : code : sp : _ = P.unpack pre- when (at /= '@' || sp /= ' ') $ void badPacket+ when (at /= '@' || sp /= ' ') skip -- TODO: make doX functions total case code of@@ -164,8 +160,8 @@ 'S' -> pure $ doS m 'F' -> do b <- lift $ checkF h- if b then pure $ doF m else loop+ if b then pure $ doF m else skip 'P' -> pure $ doP m- 'E' -> throwError $ "mpg321 error: " ++ P.unpack m- _ -> badPacket+ 'E' -> throwError $ Just $ "mpg321 error: " ++ P.unpack m+ _ -> skip
README.md view
@@ -2,8 +2,8 @@ ## hmp3-ng -The `hmp3` music player, written in Haskell, dates to 2005, and has a-curses-based interface which can be used in an ordinary text terminal.+The `hmp3` music player, written in Haskell, dates to 2005, and+has a curses-based interface which can be used in a text terminal. But it has become abandonware: the last update was in June 2008, and it no longer builds with today's Haskell and standard libraries. @@ -11,34 +11,44 @@ The original Darcs repo has vanished from the Internet. However, I have a copy I checked out in 2008 (to hack on!) with all the patches-through version 1.5.1 (the latest is 1.5.2.1, which I had at one point-but cannot find), and Hackage hosts tarballs for several versions.+through version 1.5.1 (the latest is 1.5.2.1), and Hackage has tarballs+for the later versions. * I used [darcs-to-git](https://github.com/purcell/darcs-to-git) to port to Git. * I added commits for the changes in the two later published versions.-These were fairly small, the bulk being the regeneration of the-`configure` file using a newer version of GNU `autoconf`.+These were quite minor, the bulk being the automated regeneration of a+`configure` file (now gone). -* I updated the code to compile under modern GHC (8.6.5 as of this-writing) and libraries. Some code could not be directly ported,-mainly low-level optimizations, and so was replaced.+* I updated the code to compile under recent GHC (8.6.5, 8.8.1,+and 8.10.1-alpha1 as of this writing) and libraries. This required+rewriting or entirely replacing large sections, mainly low-level+optimizations. -* There is a GitHub issue tracker to cover other problems and planned-changes, and Travis integration to continuously test builds.+* Cabal is configured via the more modern+[hpack](https://github.com/sol/hpack) format. * I have added support for building with Stack. -* All C code is removed. There is still some use of the FFI.+* There is a GitHub issue tracker, and Travis integration to+continuously test builds. -* Cabal is configured via the more modern-[hpack](https://github.com/sol/hpack) format.+* I try to avoid “Not Invented Here” by using established,+up-to-date packages from Hackage. Much old code has now been+“outsourced” and simplified. -* Work on other features and changes, and documentation, is ongoing.+* All C code is removed, replaced with libraries from Hackage.+There is still some use of the FFI. -I have also made a few changes and additions to the key bindings per-my preference.+* Unicode is supported in titles and filenames, and Unicode characters+are utilized to sharpen the interface.++* Several additions and changes have been made to the feature set+and the UI. A few of the key bindings have been modified per my+preference.++* Work on other features and changes, and documentation, is ongoing. I am still working out the flaws. Let me know if there are problems.
State.hs view
@@ -33,10 +33,9 @@ import Text.Regex.PCRE.Light (Regex) import Data.Array (listArray) import System.IO.Unsafe (unsafePerformIO)-import System.Posix.Types (ProcessID) import System.Clock (TimeSpec(..)) import System.IO (Handle)-import System.Random.Mersenne+import System.Process (ProcessHandle) import Control.Concurrent (ThreadId) import Control.Concurrent.MVar@@ -60,7 +59,7 @@ ,cursor :: !Int -- mp3 under the cursor ,clock :: !(Maybe Frame) -- current clock value ,clockUpdate :: !Bool- ,mp3pid :: !(Maybe ProcessID) -- pid of decoder+ ,mp3pid :: !(Maybe ProcessHandle) -- pid of decoder ,writeh :: !(MVar Handle) -- handle to mp3 (should be MVars?) ,errh :: !(MVar FiltHandle) -- error handle to mp3 ,readf :: !(MVar FiltHandle) -- r/w pipe to mp3@@ -82,7 +81,6 @@ ,modified :: !(MVar ()) -- Set when redrawable components of -- the state are modified. The ui -- refresh thread waits on this.- ,randomGen :: MTGen ,drawLock :: !(MVar ()) -- simple semaphore for display } @@ -123,7 +121,6 @@ ,mode = Normal ,minibuffer = Fast P.empty defaultSty ,uptime = P.empty- ,randomGen = unsafePerformIO (newMTGen Nothing) ,drawLock = unsafePerformIO (newMVar ()) }
Style.hs view
@@ -60,11 +60,11 @@ = RGB {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 | Default | Reverse- deriving (Eq,Ord)+ deriving stock (Eq,Ord) -- | Foreground and background color pairs data Style = Style !Color !Color - deriving (Eq,Ord)+ deriving stock (Eq,Ord) -- | Can hold an optimized ByteString or a Unicode String. data AmbiString = B !ByteString | U !String@@ -327,7 +327,7 @@ , hmp3_warnings :: (String,String) , hmp3_blockcursor :: (String,String) , hmp3_progress :: (String,String)- } deriving (Show,Read)+ } deriving stock (Show,Read) -- -- | Read the ~/.hmp3 file, and construct a UIStyle from it, to insert
Syntax.hs view
@@ -28,6 +28,7 @@ module Syntax where import qualified Data.ByteString.Char8 as P (concat,pack,ByteString)+import Data.Fixed (Fixed, E2) ------------------------------------------------------------------------ --@@ -75,7 +76,8 @@ { id3title :: !P.ByteString , id3artist :: !P.ByteString , id3album :: !P.ByteString- , id3str :: !P.ByteString } -- cache screen string to draw+ , id3str :: !P.ByteString+ } -- , year :: Maybe P.ByteString -- , genre :: Maybe P.ByteString }@@ -122,10 +124,10 @@ -- there's no need to evaluate all the others. -- data Frame = Frame {- currentFrame :: Int,- framesLeft :: Int,- currentTime :: (Int,Int),- timeLeft :: (Int,Int)+ currentFrame :: !Int,+ framesLeft :: !Int,+ currentTime :: !(Fixed E2),+ timeLeft :: !(Fixed E2) } -- @P {0, 1, 2}@@ -136,9 +138,10 @@ data Status = Stopped | Paused | Playing- deriving (Eq, Show)+ deriving stock (Eq, Show) -data Mode = Normal | Loop | Random deriving (Eq,Bounded,Enum) -- for pred,succ+data Mode = Normal | Loop | Random+ deriving stock (Eq,Bounded,Enum) ------------------------------------------------------------------------
UI.hs view
@@ -54,7 +54,7 @@ import Data.List (isPrefixOf) import Data.Array ((!), bounds, Array, listArray) import Data.Array.Base (unsafeAt)-import Control.Monad (when, void)+import Control.Monad (when, void, guard) import Control.Exception (catch, handle, SomeException) import System.IO (stderr, hFlush) import System.Posix.Signals (raiseSignal, sigTSTP, installHandler, Handler(..))@@ -249,10 +249,12 @@ PId3 a = draw w x st z PInfo b = draw w x st z s = UTF8.toString a- line | gap >= 0 = [U s, B $ spaces $ gap+1, B b]- | True = [U $ ellipsize lim s, B " ", B b]- where lim = x' - 5 - P.length b+ line | gap >= 0 = [U s, B $ spaces gap] ++ right+ | True = [U $ ellipsize lim s] ++ right+ where lim = x' - 5 - (if showId3 then P.length b else -1) gap = lim - displayWidth s+ showId3 = x' > 59+ right = if showId3 then [B " ", B b] else [] -- | Id3 Info instance Element PId3 where@@ -284,13 +286,15 @@ sty = helpscreen . config $ st f :: [Char] -> P.ByteString -> P.ByteString- f cs ps = - let p = str `P.append` ps- s = P.pack (take (tot - P.length p) (repeat ' '))- in p `P.append` s+ f cs ps =+ let p = str <> ps+ rt = tot - P.length p+ in if rt > 0+ then p <> spaces rt+ else P.take (tot - 1) p <> UTF8.fromString "…" where- tot = round $! fromIntegral w * (0.8::Float)- len = round $! fromIntegral tot * (0.2::Float)+ tot = max (min w 3) $! round $! fromIntegral w * (0.8::Float)+ len = max 2 $! round $! fromIntegral tot * (0.2::Float) str = P.take len $ P.intercalate " " ([""] ++ map pprIt cs ++ [P.replicate len ' '])@@ -298,7 +302,8 @@ pprIt c = case c of '\n' -> "Enter" '\f' -> "^L"- '\\' -> "'\\'"+ '\\' -> "\\"+ ' ' -> "Space" _ -> case charToKey c of Curses.KeyUp -> "Up" Curses.KeyDown -> "Down"@@ -309,25 +314,28 @@ Curses.KeyEnd -> "End" Curses.KeyHome -> "Home" Curses.KeyBackspace -> "Backspace"- _ -> P.pack $ show c+ _ -> P.singleton c ------------------------------------------------------------------------ -- | The time used and time left instance Element PTimes where- draw _ _ _ Nothing = PTimes $ Fast (spaces 5) defaultSty- draw (_,x) _ _ (Just fr) = PTimes $ FancyS $- [(spc2, defaultSty)- ,(B elapsed, defaultSty)- ,(B gap, defaultSty)- ,(B remaining,defaultSty)]+ draw _ _ _ Nothing = PTimes $ Fast (spaces 5) defaultSty+ draw (_,x) _ _ (Just Frame {..}) =+ PTimes $ FancyS $ map (, defaultSty)+ if x - 4 < P.length elapsed+ then [B " "]+ else [spc2, B elapsed]+ ++ (guard (distance > 0) *> [B gap, B remaining]) where- elapsed = P.pack $ printf "%d:%02d" lm lm'- remaining = P.pack $ printf "-%d:%02d" rm rm'- (lm,lm') = quotRem (fst . currentTime $ fr) 60- (rm,rm') = quotRem (fst . timeLeft $ fr) 60+ 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 ------------------------------------------------------------------------ @@ -339,7 +347,7 @@ (Style _ bg) = progress (config st) bgs = Style bg bg - draw (_,w) _ st (Just fr) = ProgressBar . FancyS $+ draw (_,w) _ st (Just Frame {..}) = ProgressBar . FancyS $ [(spc2,defaultSty) ,((B $ spaces distance),fgs) ,((B $ spaces (width - distance)),bgs)]@@ -347,15 +355,12 @@ width = w - 4 total = curr + left distance = round ((curr / total) * fromIntegral width)- curr = toFloat (currentTime fr)- left = toFloat (timeLeft fr)+ curr = realToFrac currentTime :: Float+ left = realToFrac timeLeft (Style fg bg) = progress (config st) bgs = Style bg bg fgs = Style fg fg - toFloat (x,y) | x `seq` y `seq` False = undefined- toFloat (x,y) = (fromIntegral x :: Float) + (fromIntegral y / 100)- ------------------------------------------------------------------------ -- | Version info@@ -389,39 +394,40 @@ PMode2 m' = draw a b c d instance Element PlayInfo where- draw _ _ st _ = PlayInfo $ P.concat- [percent- , " ("- ,P.pack (show (1 + ( snd . bounds . folders $ st)))+ draw _ _ st _ = PlayInfo $ P.concat [+ -- TODO pregenerate as template+ spaces (P.length numd - P.length curd)+ , curd+ , "/", numd , " dir"- ,if (snd . bounds $ folders st) == 1 then P.empty else plural- , ", "- ,P.pack (show . size $ st)+ , onPlural (snd . bounds $ folders st) "" "s"+ , " "+ , spaces (P.length numf - P.length curf)+ , curf+ , "/", numf , " file"- ,if size st == 1 then P.empty else plural- , ")"]+ , onPlural (size st) "" "s"+ ] where- plural = "s" -- expose to inlining- pct = "%"- curr = cursor st-- percent | percent' == 0 && curr == 0 = "top"- | percent' == 100 = "all"- | otherwise = if P.length s == 2 then ' ' `P.cons` s else s- where - s = P.pack (show percent') `P.append` pct-- percent' :: Int - percent' = round $ ((fromIntegral curr) / - ((fromIntegral . size $ st) - 1) * 100.0 :: Float)+ 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) instance Element PlayTitle where draw a@(_,x) b c d =- PlayTitle $ FancyS [- (B $ P.concat [space,inf,spaces gapl], hl),- (U modes, hl),- (B $ P.concat [spaces gapr,time,space,ver,space], hl)- ]+ PlayTitle $ FancyS $ map (,hl)+ if gap >= 2+ then [B $ P.concat [space,inf,spaces gapl], U modes,+ B $ P.concat [spaces gapr,time,space,ver,space]]+ else let gap' = x - modlen; gapl' = gap' `div` 2+ in if gap' >= 2+ then [B $ spaces gapl', U modes, B $ spaces $ gap' - gapl']+ else [B space, U $ take (x-2) modes, B space] where PlayInfo inf = draw a b c d PTime time = draw a b c d@@ -434,7 +440,7 @@ gap = x - modlen - lsize - rsize gapl = 1 `max` ((side - lsize) `min` gap) gapr = 1 `max` (gap - gapl)- modlen = length modes+ modlen = 6 -- length modes space = spaces 1 hl = titlebar . config $ c @@ -562,7 +568,7 @@ when (helpVisible st) $ do let (HelpScreen help') = draw s (0,0) st fr :: HelpScreen (Fast fps _) = head help'- offset = (w - (P.length fps)) `div` 2+ offset = max 0 $ (w - (P.length fps)) `div` 2 height = (h - length help') `div` 2 when (height > 0) $ do Curses.wMove Curses.stdScr ((h - length help') `div` 2) offset@@ -694,11 +700,10 @@ ellipsize :: Int -> String -> String ellipsize w s | displayWidth s <= w = s- | w <= 3 = replicate w '.' | True = go 0 0 s where go !i !l (c:s') =- if l' > w-3- then take i s ++ replicate (w-3-l) ' ' ++ "..."+ if l' > w-1+ then take i s ++ replicate (w-l) '…' else go (i+1) l' s' where l' = l + charWidth c go _ _ _ = error "Should've been in first case!"
Utils.hs view
@@ -18,18 +18,7 @@ -- 02111-1307, USA. -- --- miscellaneous utilites, including:------ The POpen module provides functionality to ``open'' a process by--- creating two pipes, forking, and executing a file. *Two pipes* are--- created for *bidirectional* communication with the subprocess, unlike--- the popen in the library. This is really popen2.------ The return value of the popen command is a tuple of Handle for--- reading and writing to the subprocess------ The inspiration for this code is J Petersen's hslibs/posix/POpen.hs---+-- miscellaneous utilites module Utils where @@ -39,15 +28,9 @@ import Data.Char (toLower) import System.Clock (TimeSpec(..), diffTimeSpec) import System.Environment (getEnv)-import System.Posix.Types (Fd(..),ProcessID)-import System.Process.Internals (mkProcessHandle,ProcessHandle)-import System.Posix.Process (forkProcess,executeFile)-import System.Posix.IO (createPipe,stdInput,stdError- ,stdOutput,closeFd,dupTo) import Control.Exception (handle, SomeException) -import System.IO.Unsafe (unsafePerformIO) import Text.Printf (printf) import Control.Monad.Fail as Fail @@ -78,74 +61,6 @@ ms = quot s 60 (hs,m) = quotRem ms 60 (d,h) = quotRem hs 24----------------------------------------------------------------------------- | Repeat an action--- Also known as `forever' in the Awkward squad paper-repeatM_ :: Monad m => m a -> m ()-repeatM_ a = a >> repeatM_ a-{-# SPECIALIZE repeatM_ :: IO a -> IO () #-}-{-# INLINE repeatM_ #-}------------------------------------------------------------------------------ | Convert a (newtyped) Posix Fd to an Int we can use in other places-fdToInt :: Fd -> Int-fdToInt (Fd cint) = fromIntegral cint---- | Wrap a CPid as a System.Process.ProcessHandle-pid2phdl :: ProcessID -> ProcessHandle-pid2phdl pid = unsafePerformIO $ mkProcessHandle pid False-{-# NOINLINE pid2phdl #-}-------------------------------------------------------------------------------- provide similar functionality to popen(3), --- along with bidirectional ipc via pipes--- return's the pid of the child process------ there are two different forkProcess functions. the pre-620 was a--- unix-fork style function, and the modern function has semantics more--- like the Awkward-Squad paper. We provide implementations of popen--- using both versions, depending on which GHC the user wants to try.------ And now a third, we return stderr.--- -popen :: FilePath -> [String] -> IO (Fd, Fd, Fd, ProcessID)-popen cmd args = do- (pr, pw) <- createPipe- (cr, cw) <- createPipe- (cre, cwe) <- createPipe-- -- parent --- let parent = do closeFd cw- closeFd cwe- closeFd pr- -- child --- let child = do closeFd pw- closeFd cr- closeFd cre- exec cmd args (pr,cw,cwe)- error "exec cmd failed!" -- typing only-- pid <- forkProcess child -- fork child- parent -- and run parent code-- -- hcr <- fdToHandle cr- -- hpw <- fdToHandle pw-- return (cr,pw,cre,pid)------- execve cmd in the child process, dup'ing the file descriptors passed--- as arguments to become the child's stdin and stdout.----exec :: FilePath -> [String] -> (Fd,Fd,Fd) -> IO ()-exec cmd args (pr,cw,ce) = do- dupTo pr stdInput- dupTo cw stdOutput -- dup stderr too!- dupTo ce stdError -- dup stderr too!- executeFile cmd False args Nothing ------------------------------------------------------------------------
hmp3-ng.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: e8c27eca0f6732be68c7b3b41ae67c54be4fcf2cf0b94d9bff78ef4998bcafe6+-- hash: 994d9780cd95bd24552b97f6ace0386b76e299b1ef2f2b3fc1a7be11b4fd93ba name: hmp3-ng-version: 2.7.3.1+version: 2.9.3 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 directory names on the commandline, and saved to the@@ -47,7 +47,7 @@ Paths_hmp3_ng hs-source-dirs: ./.- default-extensions: BangPatterns BlockArguments NondecreasingIndentation OverloadedStrings ScopedTypeVariables+ default-extensions: BangPatterns BlockArguments NondecreasingIndentation OverloadedStrings ScopedTypeVariables TypeApplications DerivingStrategies RecordWildCards ghc-options: -Wall -funbox-strict-fields -threaded -Wno-unused-do-bind extra-libraries: ncursesw@@ -60,11 +60,11 @@ , containers , directory , hscurses- , mersenne-random >=1.0.0.1 , monad-extras , mtl , pcre-light >=0.3 , process+ , random , unix >=2.7 , utf8-string , zlib >=0.4