diff --git a/Core.hs b/Core.hs --- a/Core.hs +++ b/Core.hs @@ -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 diff --git a/FastIO.hs b/FastIO.hs --- a/FastIO.hs +++ b/FastIO.hs @@ -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 -- --------------------------------------------------------------------- diff --git a/Lexer.hs b/Lexer.hs --- a/Lexer.hs +++ b/Lexer.hs @@ -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 diff --git a/Lexers.hs b/Lexers.hs --- a/Lexers.hs +++ b/Lexers.hs diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/State.hs b/State.hs --- a/State.hs +++ b/State.hs @@ -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 diff --git a/Style.hs b/Style.hs --- a/Style.hs +++ b/Style.hs @@ -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 ------------------------------------------------------------------------ -- diff --git a/UI.hs b/UI.hs --- a/UI.hs +++ b/UI.hs @@ -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 diff --git a/hmp3-ng.cabal b/hmp3-ng.cabal --- a/hmp3-ng.cabal +++ b/hmp3-ng.cabal @@ -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