diff --git a/Core.hs b/Core.hs --- a/Core.hs +++ b/Core.hs @@ -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 diff --git a/FastIO.hs b/FastIO.hs --- a/FastIO.hs +++ b/FastIO.hs @@ -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 diff --git a/Keymap.hs b/Keymap.hs --- a/Keymap.hs +++ b/Keymap.hs @@ -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 diff --git a/Lexer.hs b/Lexer.hs --- a/Lexer.hs +++ b/Lexer.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/State.hs b/State.hs --- a/State.hs +++ b/State.hs @@ -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 ()) } diff --git a/Style.hs b/Style.hs --- a/Style.hs +++ b/Style.hs @@ -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 diff --git a/Syntax.hs b/Syntax.hs --- a/Syntax.hs +++ b/Syntax.hs @@ -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) ------------------------------------------------------------------------ diff --git a/UI.hs b/UI.hs --- a/UI.hs +++ b/UI.hs @@ -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!" diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -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 ------------------------------------------------------------------------ diff --git a/hmp3-ng.cabal b/hmp3-ng.cabal --- a/hmp3-ng.cabal +++ b/hmp3-ng.cabal @@ -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