hmp3-ng 2.9.3 → 2.10.0
raw patch · 16 files changed
+479/−531 lines, 16 filesdep +filepath
Dependencies added: filepath
Files
- Base.hs +47/−0
- Config.hs +1/−4
- Core.hs +90/−85
- FastIO.hs +20/−21
- Keymap.hs +10/−12
- Keymap.hs-boot +1/−1
- Lexer.hs +29/−30
- Main.hs +38/−38
- README.md +32/−29
- State.hs +14/−20
- Style.hs +10/−21
- Syntax.hs +21/−20
- Tree.hs +42/−57
- UI.hs +118/−104
- Utils.hs +0/−84
- hmp3-ng.cabal +6/−5
+ Base.hs view
@@ -0,0 +1,47 @@+--+-- Copyright (c) 2020 Galen Huntington+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License as+-- published by the Free Software Foundation; either version 2 of+-- the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA+-- 02111-1307, USA.+--++module Base (module Prelude, module X) where++import Prelude++-- As of now, just including as needed.+-- I'm using the list in rebase as an upper bound on what qualifies.++import Control.Concurrent as X+import Control.Exception as X+import Control.Monad as X+import Data.ByteString as X (ByteString)+import Data.Char as X+import Data.Fixed as X+import Data.Foldable as X+import Data.Functor as X+import Data.IORef as X+import Data.List as X ((\\), group, groupBy, isPrefixOf, sort, sortBy, intersperse)+import Data.Maybe as X+import Data.String as X+import Data.Traversable as X+import Data.Version as X+import Data.Word as X+import System.Environment as X+import System.Exit as X+import System.IO as X (Handle, hClose)+import System.IO.Unsafe as X+import Text.Printf as X+
Config.hs view
@@ -19,8 +19,8 @@ -- module Config where +import Base import Style-import Data.Version (showVersion) import Paths_hmp3_ng (version) defaultStyle :: UIStyle@@ -77,6 +77,3 @@ help :: String help = "- curses-based MP3 player"--darcsinfo :: String-darcsinfo = "darcs get http://code.haskell.org/~dons/code/hmp3"
Core.hs view
@@ -2,7 +2,7 @@ -- -- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2008, 2019 Galen Huntington+-- Copyright (c) 2008, 2019, 2020 Galen Huntington -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as@@ -36,15 +36,15 @@ jumpToMatch, jumpToMatchFile, toggleFocus, jumpToNextDir, jumpToPrevDir, loadConfig,+ FileListSource, ) where -import Prelude+import Base import Syntax import Lexer (parser) import State import Style-import Utils import FastIO (send, FiltHandle(..), newFiltHandle) import Tree hiding (File,Dir) import qualified Tree (File,Dir)@@ -53,25 +53,20 @@ import Text.Regex.PCRE.Light import {-# SOURCE #-} Keymap (keymap) -import qualified Data.ByteString.Char8 as P (ByteString,pack,empty,intercalate,singleton,unpack)+import qualified Data.ByteString.Char8 as P import Data.Array ((!), bounds, Array)-import Data.Maybe (isJust,fromJust)-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-import System.Clock (getTime, Clock(..))+import System.Process (runInteractiveProcess, waitForProcess)+import System.Clock (getTime, TimeSpec(..), Clock(..), diffTimeSpec) import System.Random (randomIO)+import System.FilePath ((</>)) import System.Posix.Process (exitImmediately) import System.Posix.User (getUserEntryForID, getRealUserID, homeDirectory) -import Control.Concurrent-import Control.Exception+type FileListSource = Either SerialT [ByteString] mp3Tool :: String@@ -84,22 +79,22 @@ ------------------------------------------------------------------------ -start :: Either SerialT [P.ByteString] -> IO ()-start ms = Control.Exception.handle (\ (e :: SomeException) -> shutdown (Just (show e))) $ do+start :: Bool -> FileListSource -> IO ()+start playNow ms = handle @SomeException (shutdown . Just . show) do - t0 <- forkIO mpgLoop -- start this off early, to give mpg321 a time to settle+ t0 <- forkIO mpgLoop -- start this off early, to give mpg321 time to settle c <- UI.start -- initialise curses (ds,fs,i,m) -- construct the state <- case ms of- Right roots -> do (a,b) <- buildTree roots- return (a,b,0,Normal)+ Right roots -> do Tree a b <- buildTree roots+ pure (a,b,0,Normal) - Left st -> return (ser_darr st- ,ser_farr st- ,ser_indx st- ,ser_mode st)+ Left st -> pure (ser_darr st+ ,ser_farr st+ ,ser_indx st+ ,ser_mode st) now <- getTime Monotonic @@ -119,7 +114,7 @@ , cursor = i , current = i , mode = m- , uptime = drawUptime now now+ , uptime = showUptime now now , boottime = now , config = c , threads = [t0,t1,t2,t3,t4,t5] }@@ -127,6 +122,7 @@ loadConfig when (0 <= (snd . bounds $ fs)) play -- start the first song+ when (not playNow) pause run -- won't restart if this fails! @@ -138,7 +134,7 @@ where handler :: SomeException -> IO () handler e =- when (not.exitTime $ e) $+ unless (exitTime e) $ (warnA . show) e >> runForever fn -- reopen the catch -- | Generic handler@@ -161,7 +157,7 @@ -- For example, if we can't start it two times in a row, perhaps give up? -- mpgLoop :: IO ()-mpgLoop = runForever $ do+mpgLoop = runForever do mmpg <- findExecutable mp3Tool case mmpg of Nothing -> quit (Just $ "Cannot find " ++ mp3Tool ++ " in path")@@ -172,7 +168,7 @@ mv <- catch (pure <$> runInteractiveProcess mpg321 ["-R","-"] Nothing Nothing) (\ (e :: SomeException) -> do warnA ("Unable to start " ++ mp3Tool ++ ": " ++ show e)- return Nothing)+ pure Nothing) case mv of Nothing -> threadDelay (1000 * 500) >> mpgLoop Just (hw, r, e, pid) -> do@@ -190,9 +186,9 @@ , info = Nothing , id3 = Nothing } - catch (waitForProcess pid) (\ (_ :: SomeException) -> return ExitSuccess)+ catch @SomeException (void $ waitForProcess pid) (\_ -> pure ()) stop <- getsST doNotResuscitate- when stop $ exitWith ExitSuccess+ when stop exitSuccess warnA $ "Restarting " ++ mpg321 ++ " ..." ------------------------------------------------------------------------@@ -211,12 +207,25 @@ uptimeLoop = runForever $ do threadDelay delay now <- getTime Monotonic- modifyST $ \st -> st { uptime = drawUptime (boottime st) now }+ modifyST $ \st -> st { uptime = showUptime (boottime st) now } where- delay = 10 * 1000 * 1000 -- refresh every 10 seconds+ delay = 5 * 1000 * 1000 -- refresh every 5 seconds ------------------------------------------------------------------------ +showUptime :: TimeSpec -> TimeSpec -> ByteString+showUptime before now+ | hs == 0 = P.pack $ printf "%dm" m+ | d == 0 = P.pack $ printf "%dh%02dm" h m+ | True = P.pack $ printf "%dd%02dh%02dm" d h m+ where+ s = sec $ diffTimeSpec before now+ ms = quot s 60+ (hs,m) = quotRem ms 60+ (d,h) = quotRem hs 24++------------------------------------------------------------------------+ -- | Once each half second, wake up a and redraw the clock clockLoop :: IO () clockLoop = runForever $ threadDelay delay >> UI.refreshClock@@ -258,33 +267,30 @@ getKeys = unsafeInterleaveIO $ do c <- UI.getKey cs <- getKeys- return (c:cs) -- A lazy list of curses keys+ pure (c:cs) -- A lazy list of curses keys ------------------------------------------------------------------------ -- | Close most things. Important to do all the jobs: shutdown :: Maybe String -> IO () shutdown ms =- (do silentlyModifyST $ \st -> st { doNotResuscitate = True }- catch writeSt (\ (_ :: SomeException) -> return ())+ do silentlyModifyST $ \st -> st { doNotResuscitate = True }+ handle @SomeException (\_ -> pure ()) writeSt withST $ \st -> do case mp3pid st of- Nothing -> return ()+ Nothing -> pure () Just pid -> do h <- readMVar (writeh st) send h Quit -- ask politely waitForProcess pid- return ())+ pure () `finally` - (do isXterm <- getsST xterm+ do isXterm <- getsST xterm UI.end isXterm when (isJust ms) $ hPutStrLn stderr (fromJust ms) >> hFlush stderr- exitImmediately ExitSuccess)- -- race. a thread might touch the screen- -- gets in the way of profiling--- return ())+ exitImmediately ExitSuccess ------------------------------------------------------------------------ -- @@ -292,21 +298,17 @@ -- right pigeon hole. -- handleMsg :: Msg -> IO ()-handleMsg (T _) = return ()+handleMsg (T _) = pure () handleMsg (I i) = modifyST $ \s -> s { info = Just i } handleMsg (F (File (Left _))) = modifyST $ \s -> s { id3 = Nothing } handleMsg (F (File (Right i))) = modifyST $ \s -> s { id3 = Just i } handleMsg (S t) = do modifyST $ \s -> s { status = t }- when (t == Stopped) $ do -- transition to next song- playNext--- vincenz: Redundant, this is checked in playNext--- r <- getsST mode--- if r == Random then playRandom else playNext+ when (t == Stopped) playNext -- transition to next song handleMsg (R f) = do- silentlyModifyST $ \st -> st { clock = Just f }+ silentlyModifyST \st -> st { clock = Just f } getsST clockUpdate >>= flip when UI.refreshClock ------------------------------------------------------------------------@@ -316,11 +318,11 @@ -- | Seek backward in song seekLeft :: IO ()-seekLeft = seek $ \g -> max 0 (currentFrame g - 400)+seekLeft = seek \g -> max 0 (currentFrame g - 400) -- | Seek forward in song seekRight :: IO ()-seekRight = seek $ \g -> currentFrame g + (min 400 (framesLeft g))+seekRight = seek \g -> currentFrame g + min 400 (framesLeft g) seekStart :: IO () seekStart = seek $ const 0@@ -331,7 +333,7 @@ seek fn = do f <- getsST clock case f of- Nothing -> return ()+ Nothing -> pure () Just g -> do withST $ \st -> do h <- readMVar (writeh st)@@ -361,7 +363,7 @@ -- | Jump to relative place, 0 to 1. jumpRel :: Float -> IO ()-jumpRel r | r < 0 || r >= 1 = return ()+jumpRel r | r < 0 || r >= 1 = pure () | True = modifySTM \st -> pure st { cursor = floor $ fromIntegral (size st) * r } @@ -370,8 +372,10 @@ jumpTo st fn = do let l = max 0 (size st - 1) i = fn (cursor st)- n = if i > l then l else if i < 0 then 0 else i- return st { cursor = n }+ n | i > l = l+ | i < 0 = 0+ | True = i+ pure st { cursor = n } ------------------------------------------------------------------------ @@ -379,12 +383,8 @@ play :: IO () play = modifySTM $ \st -> if current st == cursor st- then do- n' <- randomIO- let n = abs n' `mod` (size st -1)- playAtN st (const n)- else- playAtN st (const $ cursor st)+ then jumpToRandom st+ else playAtN st (const $ cursor st) playCur :: IO () playCur = modifySTM $ \st -> playAtN st (const $ cursor st)@@ -394,12 +394,16 @@ st <- getsST id appendFile ".hmp3-delete" . (++"\n") . P.unpack $ let fe = music st ! cursor st- in (P.intercalate (P.singleton '/') [(dname $ folders st ! fdir fe),(fbase fe)])+ in P.intercalate (P.singleton '/') [dname $ folders st ! fdir fe, fbase fe] -- | Play a random song playRandom :: IO ()-playRandom = modifySTM $ \st -> do+playRandom = modifySTM jumpToRandom++-- | Jump to a random song+jumpToRandom :: HState -> IO HState+jumpToRandom st = do n' <- randomIO let n = abs n' `mod` (size st - 1) playAtN st (const n)@@ -416,7 +420,7 @@ case () of {_ | i > 0 -> playAtN st (subtract 1) -- just the prev track | mode st == Loop -> playAtN st (const (size st - 1)) -- maybe loop- | otherwise -> return st -- else stop at end+ | otherwise -> pure st -- else stop at end } -- | Play the song following the current song, if we're not at the end@@ -431,7 +435,7 @@ case () of {_ | i < size st - 1 -> playAtN st (+ 1) -- just the next track | mode st == Loop -> playAtN st (const 0) -- maybe loop- | otherwise -> return st -- else stop at end+ | otherwise -> pure st -- else stop at end } -- | Generic next song selection@@ -440,17 +444,17 @@ playAtN st fn = do let m = music st i = current st- fe = m ! (fn i)+ fe = m ! fn i -- unsure of this GBH (2008) f = P.intercalate (P.singleton '/')- [(dname $ folders st ! fdir fe),(fbase fe)]+ [dname $ folders st ! fdir fe, fbase fe] j = cursor st st' = st { current = fn i , status = Playing , cursor = if i == cursor st then fn i else j } h <- readMVar (writeh st) send h (Load f)- return st'+ pure st' ------------------------------------------------------------------------ @@ -466,7 +470,7 @@ -- | Move cursor to currently playing song jumpToPlaying :: IO ()-jumpToPlaying = modifyST $ \st -> st { cursor = (current st) }+jumpToPlaying = modifyST $ \st -> st { cursor = current st } -- | Move cursor to first song in next directory (or wrap) jumpToNextDir, jumpToPrevDir :: IO ()@@ -479,7 +483,7 @@ let i = fdir (music st ! cursor st) len = 1 + (snd . bounds $ folders st) d = fn i len- in st { cursor = dlo ((folders st) ! d) }+ in st { cursor = dlo (folders st ! d) } ------------------------------------------------------------------------ @@ -521,14 +525,14 @@ Left _ -> Nothing Right v -> Just (v,sw) case mre of- Nothing -> return (st,False) -- no pattern+ Nothing -> pure (st,False) -- no pattern Just (p,forwards) -> do let (fs,cur,m) = k st {- loop fn inc n- | fn n = return Nothing+ | fn n = pure Nothing | otherwise = do let s = extract (fs ! n) case match p s [] of@@ -537,22 +541,22 @@ check n = let s = extract (fs ! n) in case match p s [] of- Nothing -> return Nothing- Just _ -> return $ Just n+ Nothing -> pure Nothing+ Just _ -> pure $ Just n -- mi <- if forwards then loop (>=m) (+1) (cur+1) -- else loop (<0) (subtract 1) (cur-1)- mi <- liftM msum $ mapM check $- if forwards then [cur+1..m-1] ++ [0..cur]- else [cur-1,cur-2..0] ++ [m-1,m-2..cur]+ mi <- fmap msum $ mapM check $+ if forwards then [cur+1..m-1] ++ [0..cur]+ else [cur-1,cur-2..0] ++ [m-1,m-2..cur] let st' = st { regex = Just (p,forwards==sw) }- return $ case mi of+ pure case mi of Nothing -> (st',False) Just i -> (st' { cursor = sel i st }, True) - when (not found) $ putmsg (Fast "No match found." defaultSty) >> touchST+ unless found $ putmsg (Fast "No match found." defaultSty) *> touchST ------------------------------------------------------------------------ @@ -579,7 +583,7 @@ writeSt = do home <- getHome let f = home </> ".hmp3db"- withST $ \st -> do+ withST \st -> do let arr1 = music st arr2 = folders st idx = current st@@ -597,13 +601,13 @@ home <- getHome let f = home </> ".hmp3db" b <- doesFileExist f- if b then liftM Just $! readTree f else return Nothing+ if b then Just <$!> readTree f else pure Nothing -- | Find a user's home in a canonical sort of way getHome :: IO String-getHome = Control.Exception.catch- (getRealUserID >>= getUserEntryForID >>= (return . homeDirectory))- (\ (_ :: SomeException) -> getEnv "HOME")+getHome = catch @SomeException+ do getRealUserID >>= getUserEntryForID <&> homeDirectory+ do const $ getEnv "HOME" ------------------------------------------------------------------------ -- Read styles from ~/.hmp3@@ -615,10 +619,11 @@ b <- doesFileExist f if b then do str <- readFile f- msty <- catch (readM str >>= return . Just)- (\ (_ :: SomeException) -> warnA "Parse error in ~/.hmp3" >> return Nothing)+ msty <- catch (fmap Just $ evaluate $ read str)+ (\ (_ :: SomeException) ->+ warnA "Parse error in ~/.hmp3" $> Nothing) case msty of- Nothing -> return ()+ Nothing -> pure () Just rsty -> do let sty = buildStyle rsty initcolours sty
FastIO.hs view
@@ -1,6 +1,6 @@ -- -- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019 Galen Huntington+-- Copyright (c) 2019, 2020 Galen Huntington -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as@@ -22,6 +22,8 @@ module FastIO where +import Base+ import Syntax (Pretty(ppr)) import qualified Data.ByteString.Char8 as P@@ -31,11 +33,8 @@ import System.Posix.Files.ByteString import System.Posix.Directory.ByteString -import System.IO (Handle,hFlush)-import Data.IORef--import Control.Exception (catch, bracket, SomeException)-import Control.Monad.Extra (sequenceWhile)+import System.IO (hFlush)+import Control.Monad.Extra (sequenceWhile) ------------------------------------------------------------------------ @@ -44,35 +43,35 @@ dropRate = 4 -- used to be 10, but computers are faster -- | Packed string version of basename-basenameP :: P.ByteString -> P.ByteString+basenameP :: ByteString -> ByteString basenameP fps = case P.elemIndexEnd '/' fps of Nothing -> fps Just i -> P.drop (i+1) fps {-# INLINE basenameP #-} -dirnameP :: P.ByteString -> P.ByteString+dirnameP :: ByteString -> ByteString dirnameP fps = case P.elemIndexEnd '/' fps of Nothing -> "." Just i -> P.take i fps {-# INLINE dirnameP #-} -- | Packed version of listDirectory-packedGetDirectoryContents :: P.ByteString -> IO [P.ByteString]+packedGetDirectoryContents :: ByteString -> IO [ByteString] packedGetDirectoryContents fp = bracket (openDirStream fp) closeDirStream $ \ds -> fmap (filter (\p -> p/="." && p/="..")) $ sequenceWhile (not . P.null) $ repeat $ readDirStream ds -doesFileExist :: P.ByteString -> IO Bool-doesFileExist fp = catch- (not <$> isDirectory <$> getFileStatus fp)- (\ (_ :: SomeException) -> return False)+doesFileExist :: ByteString -> IO Bool+doesFileExist fp = catch @SomeException+ (not . isDirectory <$> getFileStatus fp)+ (\_ -> pure False) -doesDirectoryExist :: P.ByteString -> IO Bool-doesDirectoryExist fp = catch+doesDirectoryExist :: ByteString -> IO Bool+doesDirectoryExist fp = catch @SomeException (isDirectory <$> getFileStatus fp)- (\ (_ :: SomeException) -> return False)+ (\_ -> pure False) -packedFileNameEndClean :: P.ByteString -> P.ByteString+packedFileNameEndClean :: ByteString -> ByteString packedFileNameEndClean name = case P.unsnoc name of Just (name', ec) | ec == '\\' || ec == '/'@@ -88,7 +87,7 @@ -- | Read a line from a file stream connected to an external prcoess, -- Returning a ByteString.-getPacket :: FiltHandle -> IO P.ByteString+getPacket :: FiltHandle -> IO ByteString getPacket (FiltHandle fp _) = B.hGetLine fp -- | Check if it's one of every dropRate packets.@@ -97,11 +96,11 @@ checkF (FiltHandle _ ir) = do modifyIORef' ir (\x -> (x+1) `mod` dropRate) i <- readIORef ir- return $ dropRate==1 || i==1+ pure $ dropRate==1 || i==1 -- --------------------------------------------------------------------- -isReadable :: P.ByteString -> IO Bool+isReadable :: ByteString -> IO Bool isReadable fp = fileAccess fp True False False -- ---------------------------------------------------------------------@@ -115,7 +114,7 @@ -- white space removed from the end. I.e., -- -- > reverse . (dropWhile isSpace) . reverse == dropSpaceEnd-dropSpaceEnd :: P.ByteString -> P.ByteString+dropSpaceEnd :: ByteString -> ByteString {-# INLINE dropSpaceEnd #-} dropSpaceEnd bs = P.take (P.length bs - count) bs where count = B.foldl' go 0 bs
Keymap.hs view
@@ -1,6 +1,6 @@ -- -- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2008, 2019 Galen Huntington+-- Copyright (c) 2008, 2019, 2020 Galen Huntington -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as@@ -32,20 +32,20 @@ -- module Keymap where -import Prelude hiding (all)+import Prelude ()+import Base hiding (all) import Core import State (getsST, touchST, HState(helpVisible)) import Style (defaultSty, StringA(Fast)) import qualified UI (resetui)-import UI.HSCurses.Curses (Key(..), decodeKey) import Lexers ((>|<),(>||<),action,meta,execLexer ,alt,with,char,Regexp,Lexer) -import Data.List ((\\), find)+import UI.HSCurses.Curses (Key(..), decodeKey) -import qualified Data.ByteString.Char8 as P (ByteString, pack, singleton)-import qualified Data.Map as M (fromList, lookup, Map)+import qualified Data.ByteString.Char8 as P+import qualified Data.Map as M data Search = SearchFile | SearchDir @@ -71,9 +71,7 @@ all = commands >||< search commands :: LexerS-commands = (alt keys) `action` \[c] -> Just $ case M.lookup c keyMap of- Nothing -> return () -- ignore- Just a -> a+commands = alt keys `action` \[c] -> Just $ fromMaybe (pure ()) $ M.lookup c keyMap ------------------------------------------------------------------------ @@ -113,7 +111,7 @@ search_eval :: LexerS search_eval = enter- `meta` \_ (t,d,(_:pat)) -> case pat of+ `meta` \_ (t, d, _:pat) -> case pat of [] -> wrap (clrmsg >> touchST) _ -> case t of SearchFile -> wrap (jumpToMatchFile (Just pat) (toBool d))@@ -147,7 +145,7 @@ -- -- The default keymap, and its description ---keyTable :: [(P.ByteString, [Char], IO ())]+keyTable :: [(ByteString, [Char], IO ())] keyTable = [ ("Move up",@@ -205,7 +203,7 @@ innerTable :: [(Char, IO ())] innerTable = [(c, jumpRel i) | (i, c) <- zip [0.1, 0.2 ..] ['1'..'9']] -extraTable :: [(P.ByteString, [Char])]+extraTable :: [(ByteString, [Char])] extraTable = [("Search for file matching regex", ['/']) ,("Search backwards for file", ['?']) ,("Search for directory matching regex", ['\\'])
Keymap.hs-boot view
@@ -1,6 +1,6 @@ module Keymap where -import Data.ByteString+import Base import UI.HSCurses.Curses (Key) keymap :: [Char] -> [IO ()]
Lexer.hs view
@@ -1,6 +1,6 @@ -- -- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2008, 2019 Galen Huntington+-- Copyright (c) 2008, 2019, 2020 Galen Huntington -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as@@ -22,25 +22,25 @@ module Lexer ( parser ) where +import Base+ import Syntax (Msg(..),Status(..),Frame(..),Info(..),Id3(..),File(..),Tag(..)) import FastIO (FiltHandle(..), checkF, getPacket, dropSpaceEnd)-import Data.Char -import Data.Maybe (fromJust) import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.UTF8 as UTF8 import Control.Monad.Except ------------------------------------------------------------------------ -pSafeHead :: P.ByteString -> Char+pSafeHead :: ByteString -> Char pSafeHead s = if P.null s then ' ' else P.head s -readPS :: P.ByteString -> Int+readPS :: ByteString -> Int readPS = fst . fromJust . P.readInt -doP :: P.ByteString -> Msg-doP s = S $! case pSafeHead s of+doP :: ByteString -> Msg+doP s = S case pSafeHead s of '0' -> Stopped '1' -> Paused '2' -> Playing@@ -49,8 +49,8 @@ -- _ -> error "Invalid Status" -- Frame decoding status updates (once per frame).-doF :: P.ByteString -> Msg-doF s = R $ Frame {+doF :: ByteString -> Msg+doF s = R Frame { currentFrame = readPS f0 , framesLeft = readPS f1 , currentTime = read . P.unpack $ f2@@ -60,9 +60,9 @@ f0 : f1 : f2 : f3 : _ = P.split ' ' s -- Outputs information about the mp3 file after loading.-doS :: P.ByteString -> Msg-doS s = let fs = P.split ' ' $ s- in I $ Info {+doS :: ByteString -> Msg+doS s = let fs = P.split ' ' s+ in I Info { {- version = fs !! 0 , layer = read . P.unpack $ fs !! 1@@ -77,19 +77,19 @@ , bitrate = read $ P.unpack $ fs !! 10 , extension = read $ P.unpack $ fs !! 11 -}- userinfo = P.concat+ userinfo = mconcat ["mpeg " ,fs !! 0 ," " ,fs !! 10 ,"kbit/s "- ,(P.pack . show) ((readPS (fs !! 2)) `div` 1000 :: Int)+ ,(P.pack . show) (readPS (fs !! 2) `div` 1000 :: Int) ,"kHz"] } -- Track info if ID fields are in the file, otherwise file name. -- 30 chars per field?-doI :: P.ByteString -> Msg+doI :: ByteString -> Msg doI s = let f = dropSpaceEnd . P.dropWhile isSpace $ s in case P.take 4 f of cs | cs == "ID3:" -> F . File $@@ -103,7 +103,7 @@ id3 = Id3 "" "" "" "" -- break the ID3 string up- splitUp :: P.ByteString -> [P.ByteString]+ splitUp :: ByteString -> [ByteString] splitUp f | f == P.empty = [] | otherwise@@ -112,31 +112,30 @@ in a : xs' -- and some ugly code:- toId :: Id3 -> [P.ByteString] -> Id3+ toId :: Id3 -> [ByteString] -> Id3 toId i ls =- let j = case length ls of+ let arg n = normalise $ ls !! n+ j = case length ls of 0 -> i - 1 -> i { id3title = normalise $! ls !! 0 }+ 1 -> i { id3title = arg 0 } - 2 -> i { id3title = normalise $! ls !! 0- , id3artist = normalise $! ls !! 1 }+ 2 -> i { id3title = arg 0+ , id3artist = arg 1 } - _ -> i { id3title = normalise $! ls !! 0- , id3artist = normalise $! ls !! 1- , id3album = normalise $! ls !! 2 }+ _ -> i { id3title = arg 0+ , id3artist = arg 1+ , id3album = arg 2 } in j { id3str =- id3artist j `maybeJoin` id3album j `maybeJoin` id3title j }-- maybeJoin t f | P.null f = t- | True = mconcat [t, " : ", f]+ mconcat $ intersperse " : " $ filter (not . P.null)+ [id3artist j, id3album j, id3title j] } -- strip spaces, and decide if UTF-8 or ISO-8859-1- normalise :: P.ByteString -> P.ByteString+ normalise :: ByteString -> ByteString normalise raw = let bs = P.dropWhile isSpace . dropSpaceEnd $ raw- in if any (== UTF8.replacement_char) $ UTF8.toString bs+ in if UTF8.replacement_char `elem` UTF8.toString bs then UTF8.fromString $ P.unpack bs else bs
Main.hs view
@@ -1,7 +1,7 @@ -- -- Copyright (c) Don Stewart 2004-2008. -- Copyright (c) Tuomo Valkonen 2004.--- Copyright (c) 2019 Galen Huntington+-- Copyright (c) 2019, 2020 Galen Huntington -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as@@ -21,22 +21,15 @@ module Main where -import Core (start, readSt, shutdown)-import Tree (SerialT(..))-import Utils ((<+>))-import Config (darcsinfo, help, versinfo)--import qualified Data.ByteString.Char8 as P (pack,ByteString)+import Base -import Control.Exception (catch, SomeException)+import Core (start, readSt, shutdown, FileListSource)+import Config (help, versinfo) -import System.IO (hPutStrLn, stderr)-import System.Exit (ExitCode(..), exitWith)+import System.IO (hPrint, stderr) import System.Posix.Signals (installHandler, sigTERM, sigPIPE, sigINT, sigHUP ,sigALRM, sigABRT, Handler(Ignore, Default, Catch)) -import System.Environment (getArgs)- -- --------------------------------------------------------------------- -- | Set up the signal handlers @@ -49,47 +42,55 @@ -- setStoppedChildFlag True -- initSignals :: IO ()-initSignals = do +initSignals = do -- ignore- flip mapM_ [sigPIPE, sigALRM] - (\sig -> installHandler sig Ignore Nothing)+ for_ [sigPIPE, sigALRM] \sig ->+ installHandler sig Ignore Nothing - -- and exit if we get the following:- flip mapM_ [sigINT, sigHUP, sigABRT, sigTERM] $ \sig -> do- installHandler sig (Catch (do- Control.Exception.catch (shutdown Nothing) (\ (f :: SomeException) -> hPutStrLn stderr (show f))- exitWith (ExitFailure 1) )) Nothing+ -- and exit if we get the following+ for_ [sigINT, sigHUP, sigABRT, sigTERM] \sig ->+ installHandler sig (Catch (do+ catch (shutdown Nothing) (\ (f :: SomeException) -> hPrint stderr f)+ exitWith (ExitFailure 1) )) Nothing releaseSignals :: IO () releaseSignals =- flip mapM_ [sigINT, sigPIPE, sigHUP, sigABRT, sigTERM] - (\sig -> installHandler sig Default Nothing)+ for_ [sigINT, sigPIPE, sigHUP, sigABRT, sigTERM]+ \sig -> installHandler sig Default Nothing ------------------------------------------------------------------------ -- | Argument parsing. -- usage string. usage :: [String]-usage = ["Usage: hmp3 [-Vh] [FILE|DIR ...]"+usage = ["Usage: hmp3 [-VhP] [FILE|DIR ...]" ,"-V --version Show version information"- ,"-h --help Show this help"]+ ,"-h --help Show this help"+ ,"-P --paused Start in a paused state"+ ] -- | Parse the args-do_args :: [P.ByteString] -> IO (Either SerialT [P.ByteString])-do_args [] = do -- attempt to read db- x <- readSt- case x of- Nothing -> do mapM_ putStrLn usage; exitWith ExitSuccess- Just st -> return $ Left st+doArgs :: [ByteString] -> IO (Bool, FileListSource)+doArgs = loopArgs True where -do_args [s] | s == "-V" || s == "--version"- = do putStrLn (versinfo <+> help); putStrLn darcsinfo; exitWith ExitSuccess- | s == "-h" || s == "--help"- = do putStrLn (versinfo <+> help); mapM_ putStrLn usage; exitWith ExitSuccess+ loopArgs playNow [] = do -- attempt to read db+ x <- readSt+ case x of+ Nothing -> traverse_ putStrLn usage *> exitSuccess+ Just st -> pure (playNow, Left st) -do_args xs = return $ Right xs+ loopArgs _ (s:xs)+ | s == "-V" || s == "--version"+ = do verLine *> exitSuccess+ | s == "-h" || s == "--help"+ = do verLine *> traverse_ putStrLn usage *> exitSuccess+ | s == "-P" || s == "--paused"+ = loopArgs False xs+ where verLine = putStrLn $ unwords [versinfo, help] + loopArgs playNow xs = pure (playNow, Right xs)+ -- --------------------------------------------------------------------- -- | Static main. This is the front end to the statically linked -- application, and the real front end, in a sense. 'dynamic_main' calls@@ -100,8 +101,7 @@ -- main :: IO () main = do- args <- return . map P.pack =<< getArgs- files <- do_args args+ (playNow, files) <- doArgs =<< map fromString <$> getArgs initSignals- start files -- never returns+ start playNow files -- never returns
README.md view
@@ -1,37 +1,35 @@+[](https://hackage.haskell.org/package/hmp3-ng) [](https://travis-ci.com/galenhuntington/hmp3-ng) ## hmp3-ng -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.+The `hmp3` music player, written in Haskell, dates to 2005, and has a+curses interface for use in a text terminal. However, it has become+abandonware: the last update was in June 2008, and it no longer builds+with today’s Haskell and standard libraries. -This repository is a work in progress to resurrect this software.+This repository is an effort to resurrect this software. 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), 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 quite minor, the bulk being the automated regeneration of a-`configure` file (now gone).+* I used [darcs-to-git](https://github.com/purcell/darcs-to-git) to+port to Git. I manually added commits for the two later published+versions, which were only minor changes, mostly the automated+regeneration of a `configure` file (now gone). -* 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.+* The code has been updated to compile under recent GHC (currently+8.6, 8.8, 8.10, and 9.0) and libraries. This required rewriting or+entirely replacing large sections, mainly low-level optimizations. -* Cabal is configured via the more modern-[hpack](https://github.com/sol/hpack) format.+* I added support for building with Stack. -* I have added support for building with Stack.+* Cabal is configured using [hpack](https://github.com/sol/hpack)+with a `package.yaml` file. -* There is a GitHub issue tracker, and Travis integration to+* There is a public GitHub issue tracker, and Travis integration to continuously test builds. * I try to avoid “Not Invented Here” by using established,@@ -41,16 +39,20 @@ * All C code is removed, replaced with libraries from Hackage. There is still some use of the FFI. -* Unicode is supported in titles and filenames, and Unicode characters-are utilized to sharpen the interface.+* Unicode is supported in titles and filenames, and Unicode glyphs+are utilized in the interface. +* It is much more stable. The app used to crash frequently and+require restart, but I’ve had `hmp3-ng` running continuously for+more than a year with heavy use without any problems.+ * 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.+This is still a work in progress. Let me know if there are problems. ## Installation@@ -59,19 +61,19 @@ 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.+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 by installing `libncurses5-dev`. You probably also need+obtained by installing `libncurses5-dev`. You probably also need `libncursesw5-dev`. ## Use -The `hmp3` executable is called with arguments containing a list of mp3-files or directories of mp3 files. With no arguments, it will use the-playlist from the last time it was run, which is stored in `~/.hmp3db`.+The `hmp3` executable is invoked with a list of mp3 files or+directories of mp3 files. With no arguments, it will use the playlist+from the last time it was run, which is stored in `~/.hmp3db`. ``` $ hmp3 ~/Music ~/Downloads/La-La.mp3@@ -79,11 +81,12 @@ ``` Once running, `hmp3` is controlled by fairly intuitive key commands.-`h` shows a help menu, and `q` quits.+`h` shows a help menu, and `q` quits. `hmp3 -h` prints a simple help+message with options. A color scheme can be specified by writing out a `Config { .. }` value in `~/.hmp3`. See `Style.hs` for the definition. The `l`-command reloads this configuration.+command hot-reloads this configuration. ## Original authorship list
State.hs view
@@ -1,6 +1,6 @@ -- -- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019 Galen Huntington+-- Copyright (c) 2019, 2020 Galen Huntington -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as@@ -23,26 +23,20 @@ -- module State where +import Base+ import FastIO (FiltHandle(..)) import Syntax (Status(Stopped), Mode(..), Frame, Info,Id3) import Tree (FileArray, DirArray) import Style (StringA(Fast), defaultSty, UIStyle)-import qualified Data.ByteString as P (empty,ByteString) import qualified Config (defaultStyle) import Text.Regex.PCRE.Light (Regex) import Data.Array (listArray)-import System.IO.Unsafe (unsafePerformIO) import System.Clock (TimeSpec(..))-import System.IO (Handle) import System.Process (ProcessHandle) -import Control.Concurrent (ThreadId)-import Control.Concurrent.MVar-import Data.IORef --- import Control.Monad.State- ------------------------------------------------------------------------ -- A state monad over IO would be another option. @@ -71,7 +65,7 @@ ,helpVisible :: !Bool -- is the help window shown ,miniFocused :: !Bool -- is the mini buffer focused? ,mode :: !Mode -- random mode- ,uptime :: !P.ByteString+ ,uptime :: !ByteString ,boottime :: !TimeSpec ,regex :: !(Maybe (Regex,Bool)) -- most recent search pattern and direction ,xterm :: !Bool@@ -113,14 +107,14 @@ ,helpVisible = False ,miniFocused = False ,xterm = False- ,doNotResuscitate = False -- mgp321 should be be restarted+ ,doNotResuscitate = False -- mpg321 should be restarted ,config = Config.defaultStyle- ,boottime = TimeSpec 0 0+ ,boottime = 0 ,status = Stopped ,mode = Normal- ,minibuffer = Fast P.empty defaultSty- ,uptime = P.empty+ ,minibuffer = Fast mempty defaultSty+ ,uptime = mempty ,drawLock = unsafePerformIO (newMVar ()) } @@ -136,7 +130,7 @@ -- | Access a component of the state with a projection function getsST :: (HState -> a) -> IO a-getsST f = withST (return . f)+getsST f = withST (pure . f) -- | Perform a (read-only) IO action on the state withST :: (HState -> IO a) -> IO a@@ -144,24 +138,24 @@ -- | Modify the state with a pure function silentlyModifyST :: (HState -> HState) -> IO ()-silentlyModifyST f = modifyMVar_ state (return . f)+silentlyModifyST f = modifyMVar_ state (pure . f) ------------------------------------------------------------------------ modifyST :: (HState -> HState) -> IO ()-modifyST f = silentlyModifyST f >> touchST+modifyST f = silentlyModifyST f <* touchST -- | Modify the state with an IO action, triggering a refresh modifySTM :: (HState -> IO HState) -> IO ()-modifySTM f = modifyMVar_ state f >> touchST+modifySTM f = modifyMVar_ state f <* touchST -- | Modify the state with an IO action, returning a value modifySTM_ :: (HState -> IO (HState,a)) -> IO a-modifySTM_ f = modifyMVar state f >>= \a -> touchST >> return a+modifySTM_ f = modifyMVar state f <* touchST -- | Trigger a refresh. This is the only way to update the screen touchST :: IO ()-touchST = withMVar state $ \st -> tryPutMVar (modified st) () >> return ()+touchST = withMVar state \st -> void $ tryPutMVar (modified st) () forceNextPacket :: IO () forceNextPacket = do
Style.hs view
@@ -1,6 +1,6 @@ -- -- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019 Galen Huntington+-- Copyright (c) 2019, 2020 Galen Huntington -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as@@ -24,18 +24,10 @@ module Style where +import Base import qualified UI.HSCurses.Curses as Curses-import Data.ByteString (ByteString)--import Data.Char (toLower)-import Data.Word (Word8)-import Data.Maybe (fromJust)-import Data.IORef (readIORef, writeIORef, newIORef, IORef) import qualified Data.Map as M (fromList, empty, lookup, Map) -import System.IO.Unsafe (unsafePerformIO)-import Control.Exception (handle, SomeException)- ------------------------------------------------------------------------ -- | User-configurable colours@@ -134,7 +126,7 @@ -- -- | Set some colours, perform an action, and then reset the colours ---withStyle :: Style -> (IO ()) -> IO ()+withStyle :: Style -> IO () -> IO () withStyle sty fn = uiAttr sty >>= setAttribute >> fn >> reset {-# INLINE withStyle #-} @@ -179,14 +171,14 @@ initUiColors :: [Style] -> IO PairMap initUiColors stys = do ls <- sequence [ uncurry fn m | m <- zip stys [1..] ]- return (M.fromList ls)+ pure (M.fromList ls) where fn :: Style -> Int -> IO (Style, (Curses.Attr,Curses.Pair)) fn sty p = do let (CColor (a,fgc),CColor (b,bgc)) = style2curses sty- handle (\ (_ :: SomeException) -> return ()) $+ handle @SomeException (\_ -> pure ()) $ Curses.initPair (Curses.Pair p) fgc bgc- return (sty, (a `Curses.attrPlus` b, Curses.Pair p))+ pure (sty, (a `Curses.attrPlus` b, Curses.Pair p)) ------------------------------------------------------------------------ --@@ -198,15 +190,14 @@ uiAttr :: Style -> IO (Curses.Attr, Curses.Pair) uiAttr sty = do m <- readIORef pairMap- return $ lookupPair m sty+ pure $ lookupPair m sty {-# INLINE uiAttr #-} -- | Given a curses color pair, find the Curses.Pair (i.e. the pair -- curses thinks these colors map to) from the state lookupPair :: PairMap -> Style -> (Curses.Attr, Curses.Pair)-lookupPair m s = case M.lookup s m of- Nothing -> (Curses.attr0, Curses.Pair 0) -- default settings- Just v -> v+lookupPair m s =+ fromMaybe (Curses.attr0, Curses.Pair 0) (M.lookup s m) {-# INLINE lookupPair #-} -- | Keep a map of nice style defs to underlying curses pairs, created at init time@@ -348,6 +339,4 @@ where f (x,y) = Style (g x) (g y)- g x = case stringToColor x of- Nothing -> Default- Just y -> y+ g x = fromMaybe Default $ stringToColor x
Syntax.hs view
@@ -1,6 +1,6 @@ -- -- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019 Galen Huntington+-- Copyright (c) 2019, 2020 Galen Huntington -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as@@ -27,27 +27,28 @@ module Syntax where -import qualified Data.ByteString.Char8 as P (concat,pack,ByteString)-import Data.Fixed (Fixed, E2)+import Base +import qualified Data.ByteString.Char8 as P+ ------------------------------------------------------------------------ -- -- Values we may print out: -- Loads and starts playing <file> ---data Load = Load {-# UNPACK #-} !P.ByteString+newtype Load = Load ByteString instance Pretty Load where- ppr (Load f) = P.concat ["LOAD ", f]+ ppr (Load f) = mconcat ["LOAD ", f] -- If '+' or '-' is specified, jumps <frames> frames forward, or backwards, -- respectively, in the the mp3 file. If neither is specifies, jumps to -- absolute frame <frames> in the mp3 file.-data Jump = Jump {-# UNPACK #-} !Int+newtype Jump = Jump Int instance Pretty Jump where- ppr (Jump i) = P.concat ["JUMP ", P.pack . show $ i]+ ppr (Jump i) = mconcat ["JUMP ", P.pack . show $ i] -- Pauses the playback of the mp3 file; if already paused, restarts playback. data Pause = Pause@@ -69,18 +70,18 @@ data Tag = Tag -- Track info if ID fields are in the file, otherwise file name.-data File = File !(Either P.ByteString Id3)+newtype File = File (Either ByteString Id3) -- ID3 info data Id3 = Id3- { id3title :: !P.ByteString- , id3artist :: !P.ByteString- , id3album :: !P.ByteString- , id3str :: !P.ByteString+ { id3title :: !ByteString+ , id3artist :: !ByteString+ , id3album :: !ByteString+ , id3str :: !ByteString } --- , year :: Maybe P.ByteString--- , genre :: Maybe P.ByteString }+-- , year :: Maybe ByteString+-- , genre :: Maybe ByteString } @@ -99,12 +100,12 @@ -- <j>: Emphasis. Integer. -- <k>: Bitrate, in kbps. (i.e., 128.) Integer. -- <l>: Extension. Integer.-data Info = Info {- userinfo :: !P.ByteString -- user friendly string- -- version :: !P.ByteString,+newtype Info = Info {+ userinfo :: ByteString -- user friendly string+ -- version :: !ByteString, -- layer :: !Int, -- 1,2 or 3 -- sampleRate :: !Int,- -- playMode :: !P.ByteString,+ -- playMode :: !ByteString, -- modeExtns :: !Int, -- bytesPerFrame :: !Int, -- channelCount :: !Int,@@ -149,13 +150,13 @@ -- a pretty printing class -- class Pretty a where- ppr :: a -> P.ByteString+ ppr :: a -> ByteString -- -- And a wrapper type -- data Msg = T {-# UNPACK #-} !Tag- | F {-# UNPACK #-} !File+ | F !File | I {-# UNPACK #-} !Info | R {-# UNPACK #-} !Frame | S !Status
Tree.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS -fno-warn-orphans #-} -- -- Copyright (c) 2005-8 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019 Galen Huntington+-- Copyright (c) 2019, 2020 Galen Huntington -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as@@ -25,6 +25,8 @@ module Tree where +import Base+ import FastIO import Syntax (Mode(..)) import qualified Data.ByteString.Char8 as P@@ -32,17 +34,11 @@ import Codec.Compression.GZip import Data.Binary- import Data.Array-import Data.Maybe (catMaybes)-import Data.Char (toLower)-import Data.List (sortBy,sort,foldl',groupBy)+import System.IO (hPrint, stderr) -import System.IO (hPutStrLn,stderr)-import Control.Exception(handle, SomeException)-import Control.Monad (liftM) -type FilePathP = P.ByteString+type FilePathP = ByteString -- | A filesystem hierarchy is flattened to just the end nodes type DirArray = Array Int Dir@@ -63,21 +59,22 @@ File { fbase :: !FilePathP -- ^ basename of file , fdir :: !Int } -- ^ index of Dir entry +data Tree = Tree !DirArray !FileArray+ -- -- | Given the start directories, populate the dirs and files arrays ---buildTree :: [FilePathP] -> IO (DirArray, FileArray)+buildTree :: [FilePathP] -> IO Tree buildTree fs = do- (os,dirs) <- partition fs -- note we will lose the ordering of files given on cmd line.+ (os, dirs) <- partition fs -- note we will lose the ordering of files given on cmd line. - let loop xs | seq xs False = undefined -- strictify- loop [] = return []+ let loop [] = pure [] loop (a:xs) = do- (m,ds) <- expandDir a- ms <- loop $! ds ++ xs -- add to work list- return $! m : ms+ (m, ds) <- expandDir a+ ms <- loop $ ds ++ xs -- add to work list+ pure $ m : ms - ms' <- liftM catMaybes $! loop dirs+ ms' <- catMaybes <$> loop dirs let extras = merge . doOrphans $ os ms = ms' ++ extras@@ -86,12 +83,11 @@ dirsArray = listArray (0,length dirls - 1) (reverse dirls) fileArray = listArray (0, n-1) (reverse filels) - dirsArray `seq` fileArray `seq` return $ (dirsArray, fileArray)+ pure $! Tree dirsArray fileArray -- | Create nodes based on dirname for orphan files on cmdline doOrphans :: [FilePathP] -> [(FilePathP, [FilePathP])]-doOrphans [] = []-doOrphans (f:xs) = (dirnameP f, [basenameP f]) : doOrphans xs+doOrphans = map \f -> (dirnameP f, [basenameP f]) -- | Merge entries with the same root node into a single node merge :: [(FilePathP, [FilePathP])] -> [(FilePathP, [FilePathP])]@@ -99,7 +95,7 @@ merge xs = let xs' = sortBy (\a b -> fst a `compare` fst b) xs xs''= groupBy (\a b -> fst a == fst b) xs'- in catMaybes $ map flatten xs''+ in mapMaybe flatten xs'' where flatten :: [(FilePathP,[FilePathP])] -> Maybe (FilePathP, [FilePathP]) flatten [] = Nothing -- can't happen@@ -108,11 +104,11 @@ -- | fold builder, for generating Dirs and Files make :: (Int,Int,[Dir],[File]) -> (FilePathP,[FilePathP]) -> (Int,Int,[Dir],[File]) make (i,n,acc1,acc2) (d,fs) =- case listToDir n d fs of- (dir,n') -> case map makeFile fs of- fs' -> (i+1, n', dir:acc1, (reverse fs') ++ acc2)- where- makeFile f = File (basenameP f) i+ let (dir, n') = listToDir n d fs+ fs'= map makeFile fs+ in (i+1, n', dir:acc1, reverse fs' ++ acc2)+ where+ makeFile f = File (basenameP f) i ------------------------------------------------------------------------ @@ -124,14 +120,14 @@ expandDir :: FilePathP -> IO (Maybe (FilePathP, [FilePathP]), [FilePathP]) expandDir f | seq f False = undefined -- stricitfy expandDir f = do- ls_raw <- Control.Exception.handle (\ (e :: SomeException) -> hPutStrLn stderr (show e) >> return []) $- packedGetDirectoryContents f- let ls = map (\s -> P.intercalate (P.singleton '/') [f,s]) . sort . filter validFiles $! ls_raw- ls `seq` return ()+ ls_raw <- handle @SomeException (\e -> hPrint stderr e $> [])+ $ packedGetDirectoryContents f+ let ls = (map \s -> P.intercalate (P.singleton '/') [f,s])+ . sort . filter validFiles $ ls_raw (fs',ds) <- partition ls let fs = filter onlyMp3s fs' v = if null fs then Nothing else Just (f,fs)- return (v,ds)+ pure (v,ds) where notEdge p = p /= dot && p /= dotdot validFiles p = notEdge p@@ -151,45 +147,34 @@ let dir = Dir { dname = packedFileNameEndClean d , dsize = len , dlo = n- , dhi = n + len - 1 } in (dir, n')+ , dhi = n + len - 1+ } in (dir, n') where len = length fs n' = n + len --- | break a list of file paths into a pair of subliests corresponding+-- | break a list of file paths into a pair of sublists corresponding -- to the paths that point to files and to directories. partition :: [FilePathP] -> IO ([FilePathP], [FilePathP])-partition xs | seq xs False = undefined -- how to make `partition' strict-partition [] = return ([],[])+partition [] = pure ([],[]) partition (a:xs) = do (fs,ds) <- partition xs x <- doesFileExist a if x then do y <- isReadable a- return $! if y then (a:fs, ds) else (fs, ds)- else return (fs, a:ds)+ pure if y then (a:fs, ds) else (fs, ds)+ else pure (fs, a:ds) ------------------------------------------------------------------------ -- -- And some more Binary instances -- -{--instance Binary a => Binary (Array Int a) where- put arr = do- put (bounds arr)- mapM_ put (elems arr)- get = do- ((x,y) :: (Int,Int)) <- get- (els :: [a]) <- sequence $ take (y+1) $ repeat get- return $! listArray (x,y) els--}- instance Binary File where put (File nm i) = put nm >> put i get = do nm <- get i <- get- return (File nm i)+ pure (File nm i) instance Binary Dir where put (Dir nm sz lo hi) = put nm >> put sz >> put lo >> put hi@@ -198,11 +183,11 @@ sz <- get lo <- get hi <- get- return (Dir nm sz lo hi)+ pure (Dir nm sz lo hi) instance Binary Mode where put = put . fromEnum- get = liftM toEnum get+ get = toEnum <$> get -- How we write everything out instance Binary SerialT where@@ -215,7 +200,7 @@ (a,b)<- get i <- get m <- get- return $ SerialT {+ pure $ SerialT { ser_farr = a ,ser_darr = b ,ser_indx = i@@ -226,10 +211,10 @@ -- | Wrap up the values we're going to dump to disk data SerialT = SerialT {- ser_farr :: FileArray,- ser_darr :: DirArray,- ser_indx :: Int,- ser_mode :: Mode+ ser_farr :: !FileArray,+ ser_darr :: !DirArray,+ ser_indx :: !Int,+ ser_mode :: !Mode } writeTree :: FilePath -> SerialT -> IO ()@@ -237,4 +222,4 @@ readTree :: FilePath -> IO SerialT readTree f = do s <- L.readFile f- return (decode (decompress s))+ pure (decode (decompress s))
UI.hs view
@@ -2,7 +2,7 @@ -- -- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019 Galen Huntington+-- Copyright (c) 2019, 2020 Galen Huntington -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as@@ -41,8 +41,9 @@ ) where +import Base+ import Style-import Utils (isLightBg) import FastIO (basenameP) import Tree (File(fdir, fbase), Dir(dname)) import State@@ -51,15 +52,10 @@ import qualified UI.HSCurses.Curses as Curses import {-# SOURCE #-} Keymap (extraTable, keyTable, unkey, charToKey) -import Data.List (isPrefixOf) import Data.Array ((!), bounds, Array, listArray) import Data.Array.Base (unsafeAt)-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(..))-import System.Posix.Env (getEnv, putEnv)-import Text.Printf import Foreign.C.String import Foreign.C.Types@@ -83,18 +79,18 @@ -- start :: IO UIStyle start = do- Control.Exception.handle (\ (_ :: SomeException) -> return ()) $ do -- tweak for OpenBSD console- thisterm <- getEnv "TERM"+ handle @SomeException (\_ -> pure ()) do+ thisterm <- lookupEnv "TERM" case thisterm of - Just "vt220" -> putEnv "TERM=xterm-color"+ Just "vt220" -> setEnv "TERM" "xterm-color" Just t | "xterm" `isPrefixOf` t -> silentlyModifyST $ \st -> st { xterm = True }- _ -> return ()+ _ -> pure () Curses.initCurses case Curses.cursesSigWinch of Just wch -> void $ installHandler wch (Catch resetui) Nothing- _ -> return () -- handled elsewhere+ _ -> pure () -- handled elsewhere colorify <- Curses.hasColors light <- isLightBg@@ -107,7 +103,7 @@ Curses.keypad Curses.stdScr True -- grab the keyboard runDraw nocursor - return sty+ pure sty -- | Reset resetui :: IO ()@@ -115,9 +111,9 @@ -- | And force invisible nocursor :: Draw-nocursor = Draw $ do- Control.Exception.catch (void $ Curses.cursSet Curses.CursorInvisible) - (\ (_ :: SomeException) -> return ())+nocursor = Draw do+ handle @SomeException (\_ -> pure ()) $+ void $ Curses.cursSet Curses.CursorInvisible -- -- | Clean up and go home. Refresh is needed on linux. grr.@@ -147,10 +143,10 @@ k <- Curses.getCh if k == Curses.KeyResize then do- when (Curses.cursesSigWinch == Nothing) $+ when (isNothing Curses.cursesSigWinch) do runDraw $ redraw <> resizeui getKey- else return $ unkey k+ else pure $ unkey k -- | Resize the window -- From "Writing Programs with NCURSES", by Eric S. Raymond and Zeyd M. Ben-Halim@@ -176,17 +172,32 @@ refreshClock :: IO () refreshClock = runDraw $ redrawJustClock <> Draw Curses.refresh +--+-- | Some evil to work out if the background is light, or dark. Assume dark.+--+isLightBg :: IO Bool+isLightBg = handle @SomeException (\_ -> pure False) do+ e <- getEnv "HMP_HAS_LIGHT_BG"+ pure $ map toLower e == "true"+ ------------------------------------------------------------------------ -type Pos = (Int{-H-}, Int{-W-})-type Size = (Int{-H-}, Int{-W-})+-- (prefix some with underscore to avoid unused warnings)+data Pos = Pos { posY, _posX :: !Int }+data Size = Size { _sizeH, sizeW :: !Int } +data DrawData = DD {+ drawSize :: Size,+ drawPos :: Pos,+ drawState :: HState,+ drawFrame :: Maybe Frame+ }+ -- -- | A class for renderable objects, given the application state, and -- for printing the object as a list of strings ---class Element a where- draw :: Size -> Pos -> HState -> Maybe Frame -> a+class Element a where draw :: DrawData -> a -- -- | The elements of the play mode widget@@ -204,29 +215,25 @@ newtype PlayList = PlayList [StringA] newtype PPlaying = PPlaying StringA-newtype PVersion = PVersion P.ByteString+newtype PVersion = PVersion ByteString newtype PMode = PMode String newtype PMode2 = PMode2 String newtype ProgressBar = ProgressBar StringA newtype PTimes = PTimes StringA -newtype PInfo = PInfo P.ByteString-newtype PId3 = PId3 P.ByteString-newtype PTime = PTime P.ByteString+newtype PInfo = PInfo ByteString+newtype PId3 = PId3 ByteString+newtype PTime = PTime ByteString newtype PlayTitle = PlayTitle StringA-newtype PlayInfo = PlayInfo P.ByteString+newtype PlayInfo = PlayInfo ByteString newtype PlayModes = PlayModes String newtype HelpScreen = HelpScreen [StringA] ------------------------------------------------------------------------ instance Element PlayScreen where- draw w x y z = PlayScreen a b c- where- a = draw w x y z :: PPlaying- b = draw w x y z :: ProgressBar- c = draw w x y z :: PTimes+ draw dd = PlayScreen (draw dd) (draw dd) (draw dd) -- | Decode the play screen printPlayScreen :: PlayScreen -> [StringA]@@ -237,40 +244,41 @@ ------------------------------------------------------------------------ instance (Element a, Element b) => Element (a,b) where- draw a b c d = (draw a b c d, draw a b c d)+ draw dd = (draw dd, draw dd) ------------------------------------------------------------------------ -- Info about the current track instance Element PPlaying where- draw w@(_,x') x st z =+ draw dd = PPlaying . FancyS $ map (, defaultSty) $ spc2 : line where- PId3 a = draw w x st z- PInfo b = draw w x st z+ x = sizeW $ drawSize dd+ PId3 a = draw dd+ PInfo b = draw dd s = UTF8.toString a 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)+ where lim = x - 5 - (if showId3 then P.length b else -1) gap = lim - displayWidth s- showId3 = x' > 59+ showId3 = x > 59 right = if showId3 then [B " ", B b] else [] -- | Id3 Info instance Element PId3 where- draw _ _ st _ = case id3 st of+ draw DD{drawState=st} = case id3 st of Just i -> PId3 $ id3str i Nothing -> PId3 $ case size st of 0 -> emptyVal- _ -> fbase $ (music st) ! (current st)+ _ -> fbase $ music st ! current st -- | mp3 information instance Element PInfo where- draw _ _ st _ = PInfo $ case info st of+ draw DD{drawState=st} = PInfo case info st of Nothing -> emptyVal Just i -> userinfo i -emptyVal :: P.ByteString+emptyVal :: ByteString emptyVal = "(empty)" spc2 :: AmbiString@@ -279,13 +287,13 @@ ------------------------------------------------------------------------ instance Element HelpScreen where- draw (_,w) _ st _ = HelpScreen $ + draw DD{drawSize=Size{sizeW=w}, drawState=st} = HelpScreen $ [ Fast (f cs h) sty | (h,cs,_) <- keyTable ] ++ [ Fast (f cs h) sty | (h,cs) <- extraTable ] where sty = helpscreen . config $ st - f :: [Char] -> P.ByteString -> P.ByteString+ f :: [Char] -> ByteString -> ByteString f cs ps = let p = str <> ps rt = tot - P.length p@@ -293,8 +301,8 @@ then p <> spaces rt else P.take (tot - 1) p <> UTF8.fromString "…" where- tot = max (min w 3) $! round $! fromIntegral w * (0.8::Float)- len = max 2 $! 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 ' '])@@ -320,8 +328,7 @@ -- | The time used and time left instance Element PTimes where- draw _ _ _ Nothing = PTimes $ Fast (spaces 5) defaultSty- draw (_,x) _ _ (Just Frame {..}) =+ draw DD { drawFrame=Just Frame {..}, drawSize=Size{sizeW=x} } = PTimes $ FancyS $ map (, defaultSty) if x - 4 < P.length elapsed then [B " "]@@ -336,21 +343,22 @@ distance = x - 4 - P.length elapsed - P.length remaining toMS :: RealFrac a => a -> (Int, Int) toMS = flip quotRem 60 . floor+ draw _ = PTimes $ Fast (spaces 5) defaultSty ------------------------------------------------------------------------ -- | A progress bar instance Element ProgressBar where- draw (_,w) _ st Nothing = ProgressBar . FancyS $- [(spc2,defaultSty) ,(B $ spaces (w-4), bgs)]+ draw dd@DD{drawSize=Size{sizeW=w}, drawState=st} = case drawFrame dd of+ Nothing -> ProgressBar . FancyS $+ [(spc2,defaultSty) ,(B $ spaces (w-4), bgs)] where (Style _ bg) = progress (config st) bgs = Style bg bg-- draw (_,w) _ st (Just Frame {..}) = ProgressBar . FancyS $- [(spc2,defaultSty)- ,((B $ spaces distance),fgs)- ,((B $ spaces (width - distance)),bgs)]+ Just Frame {..} -> ProgressBar . FancyS $+ [(spc2, defaultSty)+ ,(B $ spaces distance, fgs)+ ,(B $ spaces (width - distance), bgs)] where width = w - 4 total = curr + left@@ -365,22 +373,22 @@ -- | Version info instance Element PVersion where- draw _ _ _ _ = PVersion $ P.pack versinfo+ draw _ = PVersion $ P.pack versinfo -- | Uptime instance Element PTime where- draw _ _ st _ = PTime . uptime $ st+ draw dd = PTime . uptime $ drawState dd -- | Play mode instance Element PMode where- draw _ _ st _ = PMode $! case status st of + draw dd = PMode case status $ drawState dd of Stopped -> "◼" Paused -> "Ⅱ" Playing -> "▶" -- | Loop, normal, or random instance Element PMode2 where- draw _ _ st _ = PMode2 $ case mode st of + draw dd = PMode2 case mode $ drawState dd of Random -> "rand" Loop -> "loop" Normal -> "once"@@ -388,13 +396,13 @@ ------------------------------------------------------------------------ instance Element PlayModes where- draw a b c d = PlayModes $ m ++ ' ' : m'+ draw dd = PlayModes $ m ++ ' ' : m' where- PMode m = draw a b c d- PMode2 m' = draw a b c d+ PMode m = draw dd+ PMode2 m' = draw dd instance Element PlayInfo where- draw _ _ st _ = PlayInfo $ P.concat [+ draw dd = PlayInfo $ mconcat [ -- TODO pregenerate as template spaces (P.length numd - P.length curd) , curd@@ -409,6 +417,7 @@ , onPlural (size st) "" "s" ] where+ st = drawState dd tobs = P.pack . show onPlural 1 s _ = s onPlural _ _ p = p@@ -419,21 +428,22 @@ numd = tobs $ 1 + snd (bounds $ folders st) instance Element PlayTitle where- draw a@(_,x) b c d =+ draw dd = 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]]+ then [B $ mconcat [space,inf,spaces gapl], U modes,+ B $ mconcat [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- PlayModes modes = draw a b c d- PVersion ver = draw a b c d+ PlayInfo inf = draw dd+ PTime time = draw dd+ PlayModes modes = draw dd+ PVersion ver = draw dd + x = sizeW $ drawSize dd lsize = 1 + P.length inf rsize = 2 + P.length time + P.length ver side = (x - modlen) `div` 2@@ -442,17 +452,18 @@ gapr = 1 `max` (gap - gapl) modlen = 6 -- length modes space = spaces 1- hl = titlebar . config $ c+ hl = titlebar . config $ drawState dd -- | Playlist instance Element PlayList where- draw p@(y,x) q@(o,_) st z =- PlayList $! title - : list - ++ (replicate (height - length list - 2) (Fast P.empty defaultSty))- ++ [minibuffer st]+ draw dd@DD{ drawSize=Size y x, drawPos=Pos{posY=o}, drawState=st } =+ PlayList $+ title+ : list+ ++ replicate (height - length list - 2) (Fast P.empty defaultSty)+ ++ [minibuffer st] where- PlayTitle title = draw p q st z+ PlayTitle title = draw dd songs = music st this = current st@@ -460,7 +471,7 @@ height = y - o -- number of screens down, and then offset- buflen = height - 2+ buflen = height - 2 (screens,select) = quotRem curr buflen -- keep cursor in screen playing = let top = screens * buflen@@ -504,7 +515,7 @@ drawIt :: (Maybe Int, Style, [AmbiString]) -> StringA drawIt (Nothing, sty, v) =- FancyS $ map (, sty) $ (B $ spaces (1 + indent)) : v+ FancyS $ map (, sty) $ B (spaces (1 + indent)) : v drawIt (Just i, sty, v) = FancyS $ (U d, sty')@@ -527,16 +538,16 @@ ------------------------------------------------------------------------ -- | Calculate whitespaces, very common, so precompute likely values-spaces :: Int -> P.ByteString+spaces :: Int -> ByteString spaces n | n <= 0 = "" | n > 100 = P.replicate n ' ' -- unlikely | otherwise = arr ! n where- arr :: Array Int P.ByteString -- precompute some whitespace strs+ arr :: Array Int ByteString -- precompute some whitespace strs arr = listArray (0,100) [ P.take i s100 | i <- [0..100] ] - s100 :: P.ByteString+ s100 :: ByteString s100 = P.replicate 100 ' ' -- seems reasonable ------------------------------------------------------------------------@@ -546,13 +557,15 @@ -- redrawJustClock :: Draw redrawJustClock = Draw do- Control.Exception.handle (\ (_ :: SomeException) -> return ()) $ do+ handle @SomeException (\_ -> pure ()) do st <- getsST id let fr = clock st- s@(_,w) <- screenSize- let (ProgressBar bar) = draw s undefined st fr :: ProgressBar- (PTimes times) = {-# SCC "redrawJustClock.times" #-} draw s undefined st fr :: PTimes+ (h, w) <- screenSize+ let s = Size h w+ let (ProgressBar bar) = draw $ DD s undefined st fr :: ProgressBar+ (PTimes times) = {-# SCC "redrawJustClock.times" #-}+ draw $ DD s undefined st fr :: PTimes Curses.wMove Curses.stdScr 1 0 -- hardcoded! drawLine w bar Curses.wMove Curses.stdScr 2 0 -- hardcoded!@@ -563,12 +576,12 @@ -- -- work for drawing help. draw the help screen if it is up ---drawHelp :: HState -> Maybe Frame -> (Int,Int) -> IO ()-drawHelp st fr s@(h,w) =+drawHelp :: HState -> Maybe Frame -> Size -> IO ()+drawHelp st fr s@(Size h w) = when (helpVisible st) $ do- let (HelpScreen help') = draw s (0,0) st fr :: HelpScreen+ let (HelpScreen help') = draw $ DD s (Pos 0 0) st fr :: HelpScreen (Fast fps _) = head help'- offset = max 0 $ (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@@ -583,23 +596,24 @@ redraw :: Draw redraw = Draw $ -- linux ncurses, in particular, seems to complain a lot. this is an easy solution- Control.Exception.handle (\ (_ :: SomeException) -> return ()) $ do+ handle @SomeException (\_ -> pure ()) do s <- getsST id -- another refresh could be triggered? let f = clock s- sz@(h,w) <- screenSize+ (h, w) <- screenSize+ let sz = Size h w - let x = printPlayScreen (draw sz (0,0) s f :: PlayScreen)- y = printPlayList (draw sz (length x,0) s f :: PlayList)- a = x ++ y+ let a = let x = printPlayScreen (draw $ DD sz (Pos 0 0) s f :: PlayScreen)+ y = printPlayList (draw $ DD sz (Pos (length x) 0) s f :: PlayList)+ in x ++ y when (xterm s) $ setXterm s gotoTop mapM_ (\t -> do drawLine w t- (y',x') <- Curses.getYX Curses.stdScr+ (y, x) <- Curses.getYX Curses.stdScr fillLine- maybeLineDown t h y' x' )+ maybeLineDown t h y x ) (take (h-1) (init a)) drawHelp s f sz @@ -608,7 +622,7 @@ fillLine Curses.wMove Curses.stdScr (h-1) 0 drawLine (w-1) (last a)- when (miniFocused s) $ do -- a fake cursor+ when (miniFocused s) do -- a fake cursor drawLine 1 (Fast (spaces 1) (blockcursor . config $ s )) -- todo rendering bug here when deleting backwards in minibuffer @@ -618,7 +632,7 @@ -- drawLine :: Int -> StringA -> IO () drawLine _ (Fast ps sty) = drawAmbiString (B ps) sty-drawLine _ (FancyS ls) = sequence_ $ map (uncurry drawAmbiString) ls+drawLine _ (FancyS ls) = traverse_ (uncurry drawAmbiString) ls drawAmbiString :: AmbiString -> Style -> IO () drawAmbiString as sty = withStyle sty $ case as of@@ -633,7 +647,7 @@ maybeLineDown :: StringA -> Int -> Int -> Int -> IO () maybeLineDown (Fast s _) h y _ | s == P.empty = lineDown h y maybeLineDown _ h y x- | x == 0 = return () -- already moved down+ | x == 0 = pure () -- already moved down | otherwise = lineDown h y ------------------------------------------------------------------------@@ -645,7 +659,7 @@ -- | Fill to end of line spaces -- fillLine :: IO ()-fillLine = Control.Exception.catch (Curses.clrToEol) (\ (_ :: SomeException) -> return ()) -- harmless?+fillLine = handle @SomeException (\_ -> pure ()) Curses.clrToEol -- harmless? -- -- | move cursor to origin of stdScr.@@ -661,7 +675,7 @@ in [unsafeAt arr n | n <- [max a i .. min b j] ] {-# INLINE slice #-} --- isAscii :: P.ByteString -> Bool+-- isAscii :: ByteString -> Bool -- isAscii = P.all (<'\128') ------------------------------------------------------------------------@@ -669,7 +683,7 @@ -- -- | magics for setting xterm titles using ansi escape sequences ---setXtermTitle :: [P.ByteString] -> IO ()+setXtermTitle :: [ByteString] -> IO () setXtermTitle strs = do mapM_ (P.hPut stderr) (before : strs ++ [after]) hFlush stderr @@ -686,7 +700,7 @@ Playing -> case id3 s of Nothing -> case size s of 0 -> ["hmp3"]- _ -> [(fbase $ music s ! current s)]+ _ -> [fbase $ music s ! current s] Just ti -> id3artist ti : if P.null (id3title ti) then []
− Utils.hs
@@ -1,84 +0,0 @@--- --- Copyright (c) 2003-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019 Galen Huntington--- --- This program is free software; you can redistribute it and/or--- modify it under the terms of the GNU General Public License as--- published by the Free Software Foundation; either version 2 of--- the License, or (at your option) any later version.--- --- This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- General Public License for more details.--- --- You should have received a copy of the GNU General Public License--- along with this program; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA--- 02111-1307, USA.--- ---- miscellaneous utilites--module Utils where--import qualified Data.ByteString as P (ByteString)-import qualified Data.ByteString.Char8 as P (pack)--import Data.Char (toLower)-import System.Clock (TimeSpec(..), diffTimeSpec)-import System.Environment (getEnv)--import Control.Exception (handle, SomeException)--import Text.Printf (printf)-import Control.Monad.Fail as Fail--------------------------------------------------------------------------------- | join two path components----infixr 6 </>-infixr 6 <+>--(</>), (<+>) :: FilePath -> FilePath -> FilePath-[] </> b = b-a </> b = a ++ "/" ++ b--[] <+> b = b-a <+> b = a ++ " " ++ b----------------------------------------------------------------------------drawUptime :: TimeSpec -> TimeSpec -> P.ByteString-drawUptime before now- | hs == 0 = P.pack $ printf "%dm" m- | d == 0 = P.pack $ printf "%dh%02dm" h m- | True = P.pack $ printf "%dd%02dh%02dm" d h m- where- s = sec $ diffTimeSpec now before- ms = quot s 60- (hs,m) = quotRem ms 60- (d,h) = quotRem hs 24--------------------------------------------------------------------------------- | Some evil to work out if the background is light, or dark. Assume dark.----isLightBg :: IO Bool-isLightBg = Control.Exception.handle (\ (_ :: SomeException) -> return False) $ do- e <- getEnv "HMP_HAS_LIGHT_BG"- return $ map toLower e == "true"------------------------------------------------------------------------------ | 'readM' behaves like read, but catches failure in a monad.-readM :: (MonadFail m, Read a) => String -> m a-readM s = case [x | (x,t) <- {-# SCC "Serial.readM.reads" #-} reads s -- bad!- , ("","") <- lex t] of- [x] -> return x- [] -> Fail.fail "Serial.readM: no parse"- _ -> Fail.fail "Serial.readM: ambiguous parse"-
hmp3-ng.cabal view
@@ -1,16 +1,16 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack ----- hash: 994d9780cd95bd24552b97f6ace0386b76e299b1ef2f2b3fc1a7be11b4fd93ba+-- hash: 3ce78a070f63eb040d0a181e06c04704f783d764067ba6fad8632bc1993b6b59 name: hmp3-ng-version: 2.9.3+version: 2.10.0 synopsis: A 2019 fork of an ncurses mp3 player written in Haskell description: An mp3 player with a curses frontend. Playlists are populated by- passing directory names on the commandline, and saved to the+ passing file and directory names on the command line, and saved to the ~/.hmp3db database. Type 'h' to display the help page. Colours may be configured at runtime by editing the "~/.hmp3" file. category: Sound@@ -32,6 +32,7 @@ executable hmp3 main-is: Main.hs other-modules:+ Base Config Core FastIO@@ -43,7 +44,6 @@ Syntax Tree UI- Utils Paths_hmp3_ng hs-source-dirs: ./.@@ -59,6 +59,7 @@ , clock , containers , directory+ , filepath , hscurses , monad-extras , mtl