hmp3-ng 2.5.1 → 2.7.0
raw patch · 9 files changed
+159/−120 lines, 9 files
Files
- Core.hs +22/−15
- FastIO.hs +3/−5
- Lexer.hs +5/−1
- Lexers.hs +0/−0
- README.md +4/−3
- State.hs +8/−1
- Style.hs +4/−1
- UI.hs +110/−92
- hmp3-ng.cabal +3/−2
Core.hs view
@@ -75,9 +75,12 @@ import GHC.IO.Handle.FD (fdToHandle) --- This can be overridden with -D.-#ifndef MPG321-#define MPG321 "mpg123"+mp3Tool :: String+mp3Tool =+#ifdef MPG123+ "mpg123"+#else+ "mpg321" #endif ------------------------------------------------------------------------@@ -102,11 +105,13 @@ now <- getTime Monotonic -- fork some threads- t1 <- forkIO mpgInput+ t1 <- forkIO $ mpgInput readf t2 <- forkIO refreshLoop t3 <- forkIO clockLoop t4 <- forkIO uptimeLoop- t5 <- forkIO errorLoop+ t5 <- forkIO+ -- mpg321 uses stderr for @F messages+ $ if mp3Tool == "mpg321" then mpgInput errh else errorLoop silentlyModifyST $ \s -> s { music = fs@@ -159,22 +164,22 @@ -- mpgLoop :: IO () mpgLoop = forever $ do- mmpg <- findExecutable (MPG321 :: String)+ mmpg <- findExecutable mp3Tool case mmpg of- Nothing -> quit (Just $ "Cannot find " ++ MPG321 ++ " in path")+ 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 :: String) ["-R","-"] >>= return . Just)+ mv <- catch (popen mpg321 ["-R","-"] >>= return . Just) (\ (e :: SomeException) ->- do warnA ("Unable to start " ++ MPG321 ++ ": " ++ show e)+ do warnA ("Unable to start " ++ mp3Tool ++ ": " ++ show e) return Nothing) case mv of Nothing -> threadDelay (1000 * 500) >> mpgLoop Just (r,w,e,pid) -> do hw <- fdToHandle (fromIntegral w) -- so we can use Haskell IO- ew <- fdToHandle (fromIntegral e) -- 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@@ -199,7 +204,9 @@ -- | When the editor state has been modified, refresh, then wait -- for it to be modified again. refreshLoop :: IO ()-refreshLoop = getsST modified >>= \mvar -> forever $ takeMVar mvar >> UI.refresh+refreshLoop = do+ mvar <- getsST modified+ forever $ takeMVar mvar >> UI.refresh ------------------------------------------------------------------------ @@ -225,7 +232,7 @@ -- | Handle, and display errors produced by mpg321 errorLoop :: IO () errorLoop = forever $ do- s <- getsST errh >>= readMVar >>= hGetLine+ s <- getsST errh >>= readMVar >>= hGetLine . filtHandle if s == "No default libao driver available." then quit $ Just $ s ++ " Perhaps another instance of hmp3 is running?" else warnA s@@ -236,9 +243,9 @@ -- shutdown kills the other end of the pipe, hGetLine will fail, so we -- take that chance to exit. ---mpgInput :: IO ()-mpgInput = forever $ do- mvar <- getsST readf+mpgInput :: (HState -> MVar FiltHandle) -> IO ()+mpgInput field = forever $ do+ mvar <- getsST field fp <- readMVar mvar res <- parser fp case res of
FastIO.hs view
@@ -39,11 +39,9 @@ ------------------------------------------------------------------------ --- Copied from C comment:--- * Note that mpg321 (only) provides --skip-printing-frames=N--- * I guess we could have used that.+-- Use every nth frame. 1 for no dropping. dropRate :: Int-dropRate = 6 -- used to be 10, but computers are faster+dropRate = 4 -- used to be 10, but computers are faster -- | Packed string version of basename basenameP :: P.ByteString -> P.ByteString@@ -96,7 +94,7 @@ checkF (FiltHandle _ ir) = do modifyIORef' ir (\x -> (x+1) `mod` dropRate) i <- readIORef ir- return $ (i==1)+ return $ dropRate==1 || i==1 -- ---------------------------------------------------------------------
Lexer.hs view
@@ -40,6 +40,7 @@ '0' -> Stopped '1' -> Paused '2' -> Playing+ '3' -> Stopped -- used by mpg321 _ -> Playing -- _ -> error "Invalid Status" @@ -95,7 +96,10 @@ doI :: P.ByteString -> Msg doI s = let f = dropSpaceEnd . P.dropWhile isSpace $ s in case P.take 4 f of- cs | cs == "ID3:" -> F . File . Right . toId id3 . splitUp . P.drop 4 $ f+ cs | cs == "ID3:" -> F . File $+ let ttl = toId id3 . splitUp . P.drop 4 $ f+ -- mpg321 sometimes returns null titles+ in if P.null (id3title ttl) then Left f else Right ttl | otherwise -> F . File . Left $ f where -- a default
Lexers.hs view
README.md view
@@ -42,9 +42,10 @@ ## Installation Either `cabal install` or `stack install` will build a binary.-You will need to have `mpg123` installed, which is free software and-widely available in package managers. Although `mpg321` could also-be used, support is currently poor.+You will need to have `mpg321` installed, which is free software+and widely available in package managers. Alternatively, `mpg123`+can be used by compiling with the `-DMPG123` option, but, while your+mileage may vary, in my experience it doesn't work as well. The build depends on the package `hscurses`, which in turn requires curses dev files. In Ubuntu/Debian, for example, these can be gotten
State.hs view
@@ -62,7 +62,7 @@ ,clockUpdate :: !Bool ,mp3pid :: !(Maybe ProcessID) -- pid of decoder ,writeh :: !(MVar Handle) -- handle to mp3 (should be MVars?)- ,errh :: !(MVar Handle) -- error handle to mp3+ ,errh :: !(MVar FiltHandle) -- error handle to mp3 ,readf :: !(MVar FiltHandle) -- r/w pipe to mp3 ,threads :: ![ThreadId] -- all our threads ,id3 :: !(Maybe Id3) -- maybe mp3 id3 info@@ -83,6 +83,7 @@ -- the state are modified. The ui -- refresh thread waits on this. ,randomGen :: MTGen+ ,drawLock :: !(MVar ()) -- simple semaphore for display } ------------------------------------------------------------------------@@ -123,6 +124,7 @@ ,minibuffer = Fast P.empty defaultSty ,uptime = P.empty ,randomGen = unsafePerformIO (newMTGen Nothing)+ ,drawLock = unsafePerformIO (newMVar ()) } --@@ -168,4 +170,9 @@ forceNextPacket = do fh <- readMVar =<< getsST readf writeIORef (frameCount fh) 0++withDrawLock :: IO () -> IO ()+withDrawLock io = do+ lock <- getsST drawLock+ withMVar lock $ const io
Style.hs view
@@ -66,10 +66,13 @@ data Style = Style !Color !Color deriving (Eq,Ord) +-- | Can hold an optimized ByteString or a Unicode String.+data AmbiString = B !ByteString | U !String+ -- | A list of such values (the representation is optimised) data StringA = Fast {-# UNPACK #-} !ByteString {-# UNPACK #-} !Style- | FancyS ![(ByteString,Style)] -- one line made up of segments+ | FancyS ![(AmbiString,Style)] -- one line made up of segments ------------------------------------------------------------------------ --
UI.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ForeignFunctionInterface, TupleSections #-}+ -- -- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons -- Copyright (c) 2019 Galen Huntington@@ -29,6 +31,7 @@ -- module UI (+ runDraw, -- * Construction, destruction start, end, suspend, screenSize, refresh, refreshClock, resetui,@@ -58,9 +61,21 @@ import System.Posix.Env (getEnv, putEnv) import Text.Printf +import Foreign.C.String+import Foreign.C.Types+ import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as UTF8 ++newtype Draw = Draw (IO ())+instance Semigroup Draw where Draw x <> Draw y = Draw $ x >> y+instance Monoid Draw where mempty = Draw $ pure ()++runDraw :: Draw -> IO ()+runDraw (Draw d) = withDrawLock d+ ------------------------------------------------------------------------ --@@ -90,18 +105,18 @@ initcolours sty Curses.keypad Curses.stdScr True -- grab the keyboard- nocursor+ runDraw nocursor return sty -- | Reset resetui :: IO ()-resetui = resizeui >> nocursor >> refresh+resetui = runDraw (resizeui <> nocursor) >> refresh -- | And force invisible-nocursor :: IO ()-nocursor = do- Control.Exception.catch (Curses.cursSet Curses.CursorInvisible >> return ()) +nocursor :: Draw+nocursor = Draw $ do+ Control.Exception.catch (void $ Curses.cursSet Curses.CursorInvisible) (\ (_ :: SomeException) -> return ()) --@@ -133,15 +148,15 @@ if k == Curses.KeyResize then do when (Curses.cursesSigWinch == Nothing) $- void $ redraw >> resizeui -- do we need redraw here?+ runDraw $ redraw <> resizeui getKey else return $ unkey k -- | Resize the window -- From "Writing Programs with NCURSES", by Eric S. Raymond and Zeyd M. Ben-Halim ---resizeui :: IO (Int,Int)-resizeui = do+resizeui :: Draw+resizeui = Draw $ void $ do Curses.endWin Curses.resetParams do@@ -156,10 +171,10 @@ Curses.scrSize refresh :: IO ()-refresh = redraw >> Curses.refresh+refresh = runDraw $ redraw <> Draw Curses.refresh refreshClock :: IO ()-refreshClock = redrawJustClock >> Curses.refresh+refreshClock = runDraw $ redrawJustClock <> Draw Curses.refresh ------------------------------------------------------------------------ @@ -229,11 +244,10 @@ -- Info about the current track instance Element PPlaying where draw w@(_,x') x st z = PPlaying . FancyS $ - [(spc2, defaultSty)- ,(alignLR (x'-4) a b, defaultSty)]+ map (, defaultSty) $ spc2 : alignLR (x'-4) (UTF8.toString a) b where- (PId3 a) = draw w x st z :: PId3 - (PInfo b) = draw w x st z :: PInfo+ PId3 a = draw w x st z+ PInfo b = draw w x st z -- | Id3 Info instance Element PId3 where@@ -252,8 +266,8 @@ emptyVal :: P.ByteString emptyVal = "(empty)" -spc2 :: P.ByteString-spc2 = spaces 2+spc2 :: AmbiString+spc2 = B $ spaces 2 ------------------------------------------------------------------------ @@ -299,9 +313,9 @@ draw _ _ _ Nothing = PTimes $ Fast (spaces 5) defaultSty draw (_,x) _ _ (Just fr) = PTimes $ FancyS $ [(spc2, defaultSty)- ,(elapsed, defaultSty)- ,(gap, defaultSty)- ,(remaining,defaultSty)]+ ,(B elapsed, defaultSty)+ ,(B gap, defaultSty)+ ,(B remaining,defaultSty)] where elapsed = P.pack $ printf "%d:%02d" lm lm' remaining = P.pack $ printf "-%d:%02d" rm rm'@@ -315,15 +329,15 @@ -- | A progress bar instance Element ProgressBar where draw (_,w) _ st Nothing = ProgressBar . FancyS $- [(spc2,defaultSty) ,(spaces (w-4), bgs)]+ [(spc2,defaultSty) ,(B $ spaces (w-4), bgs)] where (Style _ bg) = progress (config st) bgs = Style bg bg draw (_,w) _ st (Just fr) = ProgressBar . FancyS $ [(spc2,defaultSty)- ,((spaces distance),fgs)- ,((spaces (width - distance)),bgs)]+ ,((B $ spaces distance),fgs)+ ,((B $ spaces (width - distance)),bgs)] where width = w - 4 total = curr + left@@ -460,67 +474,49 @@ visible = slice off (off + buflen) songs where off = screens * buflen - -- todo: put dir on its own line- visible' :: [(Maybe Int, P.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,fbase v) : loop (fdir v) vs- - -- problem: we color *after* merging with directories- -- list = [ uncurry color n- -- | n <- zip (map drawIt visible') [0..] ]+ -- TODO rewrite as fold+ visible' :: [(Maybe Int, String)]+ visible' = loop (-1) visible where+ loop _ [] = []+ loop n (v:vs) =+ let r = if fdir v > n then Just (fdir v) else Nothing+ in (r, ellipsize (x - indent - 1) $ UTF8.toString $ fbase v)+ : loop (fdir v) vs - list = [ drawIt . color . mchop $ n | n <- zip visible' [0..] ]+ list = [ drawIt . color $ n | n <- zip visible' [0..] ] - indent = (round $ (0.35 :: Float) * fromIntegral x) :: Int+ indent = (round $ (0.334 :: Float) * fromIntegral x) :: Int - color :: ((Maybe Int,P.ByteString),Int) -> (Maybe Int, StringA)+ color :: ((Maybe Int, String), Int)+ -> (Maybe Int, Style, [AmbiString]) color ((m,s),i) | i == select && i == playing = f sty3 | i == select = f sty2 | i == playing = f sty1- | otherwise = (m,Fast s defaultSty)+ | otherwise = (m, defaultSty, [U s]) where- f sty = (m, Fast (s `P.append` - (spaces (x-indent-1-P.length s)))- sty)+ f sty = (m, sty, [+ U s,+ B $ spaces (x - indent - 1 - displayWidth s)]) sty1 = selected . config $ st sty2 = cursors . config $ st sty3 = combined . config $ st - -- must mchop before drawing.- drawIt :: (Maybe Int, StringA) -> StringA- drawIt (Nothing,Fast v sty) = - Fast ((spaces (1 + indent)) `P.append` v) sty+ drawIt :: (Maybe Int, Style, [AmbiString]) -> StringA+ drawIt (Nothing, sty, v) =+ FancyS $ map (, sty) $ (B $ spaces (1 + indent)) : v - drawIt (Just i,Fast b sty) = FancyS [pref, post]+ drawIt (Just i, sty, v) = FancyS+ $ (U d, sty')+ : (B $ spaces (indent + 1 - displayWidth d), sty')+ : map (, sty) v where- pref = (d', if sty == sty2 || sty == sty3 then sty2 else sty1)- post = (b, sty)-- d = basenameP $ case size st of- 0 -> "(empty)"- _ -> dname $ folders st ! i-- spc = spaces (indent - P.length d)-- d' | P.length d > indent-1 - = P.concat [ P.take (indent+1-4) d - , (P.init ellipsis) - , spaces 1 ]-- | otherwise = P.concat [ d, spaces 1, spc ]-- drawIt _ = error "UI.drawIt: color gaves us a non-Fast StringA!"-- mchop :: ((Maybe Int,P.ByteString),Int) -> ((Maybe Int,P.ByteString),Int) - mchop a@((i,s),j)- | P.length s > (x-indent-4-1) - = ((i, P.take (x-indent-4-1) s `P.append` ellipsis),j)- | otherwise = a+ sty' = if sty == sty2 || sty == sty3 then sty2 else sty1+ d = ellipsize (indent - 1) $ UTF8.toString $ basenameP+ $ case size st of+ 0 -> "(empty)"+ _ -> dname $ folders st ! i -- -- | Decode the list of current tracks@@ -532,17 +528,19 @@ ------------------------------------------------------------------------ -- | Take two strings, and pad them in the middle-alignLR :: Int -> P.ByteString -> P.ByteString -> P.ByteString+alignLR :: Int -> String -> P.ByteString -> [AmbiString] alignLR w l r - | padding > 0 = P.concat [l, gap, r]- | otherwise = P.concat [ P.take (w - P.length r - 4 - 1) l, ellipsis, spaces 1, r]+ | padding > 0 = [U l, B gap, B r]+ -- | otherwise = [U P.take (w - P.length r - 4 - 1) l, ellipsis, spaces 1, r]+ | otherwise = [U $ ellipsize (w - P.length r - 1) l, B " ", B r] - where padding = w - P.length l - P.length r+ where padding = w - displayWidth l - P.length r gap = spaces padding -- | Calculate whitespaces, very common, so precompute likely values spaces :: Int -> P.ByteString spaces n+ | n <= 0 = "" | n > 100 = P.replicate n ' ' -- unlikely | otherwise = arr ! n where@@ -552,17 +550,13 @@ s100 :: P.ByteString s100 = P.replicate 100 ' ' -- seems reasonable -ellipsis :: P.ByteString-ellipsis = "... "-{-# INLINE ellipsis #-}- ------------------------------------------------------------------------ -- -- | Now write out just the clock line -- Speed things up a bit, just use read State. ---redrawJustClock :: IO ()-redrawJustClock = do +redrawJustClock :: Draw+redrawJustClock = Draw $ do Control.Exception.handle (\ (_ :: SomeException) -> return ()) $ do st <- getsST id@@ -597,8 +591,8 @@ -- -- | Draw the screen ---redraw :: IO ()-redraw = +redraw :: Draw+redraw = Draw $ -- linux ncurses, in particular, seems to complain a lot. this is an easy solution Control.Exception.handle (\ (_ :: SomeException) -> return ()) $ do @@ -634,19 +628,15 @@ -- | Draw a coloured (or not) string to the screen -- drawLine :: Int -> StringA -> IO ()-drawLine _ (Fast ps sty) = drawPackedString ps sty-drawLine _ (FancyS ls) = loop ls- where loop [] = return ()- loop ((l,sty):xs) = drawPackedString l sty >> loop xs+drawLine _ (Fast ps sty) = drawAmbiString (B ps) sty+drawLine _ (FancyS ls) = sequence_ $ map (uncurry drawAmbiString) ls --- much less efficient than before, could drop into FFI if pure ascii-drawPackedString :: P.ByteString -> Style -> IO ()-drawPackedString ps sty =- withStyle sty $ Curses.wAddStr Curses.stdScr- -- a hack to somewhat not mess up spacing- -- TODO have to redo length logic throughout- $ s ++ replicate (P.length ps - length s) ' '- where s = UTF8.toString ps+drawAmbiString :: AmbiString -> Style -> IO ()+drawAmbiString as sty = withStyle sty $ case as of+ B ps -> void $ B.useAsCString ps \cstr ->+ waddnstr Curses.stdScr cstr (fromIntegral $ P.length ps)+ U s -> Curses.wAddStr Curses.stdScr s+{-# INLINE drawAmbiString #-} ------------------------------------------------------------------------@@ -682,6 +672,9 @@ in [unsafeAt arr n | n <- [max a i .. min b j] ] {-# INLINE slice #-} +-- isAscii :: P.ByteString -> Bool+-- isAscii = P.all (<'\128')+ ------------------------------------------------------------------------ --@@ -711,4 +704,29 @@ then [] else [": ", id3title ti] else let (PMode pm) = draw sz (0,0) s f :: PMode in [pm]++displayWidth :: String -> Int+displayWidth = sum . map charWidth++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) ' ' ++ "..."+ else go (i+1) l' s'+ where l' = l + charWidth c+ go _ _ _ = error "Should've been in first case!"++charWidth :: Char -> Int+charWidth = fromIntegral . wcwidth . toEnum . fromEnum++foreign import ccall safe+ wcwidth :: CWchar -> CInt++-- Not exported by hscurses.+foreign import ccall safe+ waddnstr :: Curses.Window -> CString -> CInt -> IO CInt
hmp3-ng.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.6 name: hmp3-ng-version: 2.5.1+version: 2.7.0 homepage: https://github.com/galenhuntington/hmp3-ng license: GPL license-file: LICENSE@@ -45,4 +45,5 @@ Lexer Lexers State Style Syntax Tree UI Utils Paths_hmp3_ng - extensions: ScopedTypeVariables, OverloadedStrings+ extensions: ScopedTypeVariables, OverloadedStrings,+ BlockArguments, BangPatterns