diff --git a/Core.hs b/Core.hs --- a/Core.hs +++ b/Core.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- -- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- Copyright (c) 2008, 2019 Galen Huntington @@ -62,7 +64,7 @@ import System.IO (hPutStrLn, hGetLine, stderr, hFlush) import System.IO.Unsafe (unsafeInterleaveIO) import System.Process (waitForProcess) -import System.Time (getClockTime) +import System.Clock (getTime, Clock(..)) import System.Random.Mersenne import System.Posix.Process (exitImmediately) @@ -97,7 +99,7 @@ ,ser_indx st ,ser_mode st) - now <- getClockTime + now <- getTime Monotonic -- fork some threads t1 <- forkIO mpgInput @@ -201,15 +203,14 @@ ------------------------------------------------------------------------ --- | Once a minute read the clock time --- TODO use a monotonic clock +-- | The clock ticks once per minute, but check more often in case of drift. uptimeLoop :: IO () uptimeLoop = forever $ do threadDelay delay - now <- getClockTime + now <- getTime Monotonic modifyST $ \st -> st { uptime = drawUptime (boottime st) now } where - delay = 60 * 1000 * 1000 -- 1 minute + delay = 10 * 1000 * 1000 -- refresh every 10 seconds ------------------------------------------------------------------------ @@ -543,7 +544,7 @@ Nothing -> (st',False) Just i -> (st' { cursor = sel i st }, True) - when (not found) $ putmsg (Fast (P.pack "No match found.") defaultSty) >> touchST + when (not found) $ putmsg (Fast "No match found." defaultSty) >> touchST ------------------------------------------------------------------------ @@ -604,7 +605,7 @@ home <- getHome let f = home ".hmp3" b <- doesFileExist f - when b $ do -- otherwise used compiled-in values + if b then do str <- readFile f msty <- catch (readM str >>= return . Just) (\ (_ :: SomeException) -> warnA "Parse error in ~/.hmp3" >> return Nothing) @@ -614,6 +615,10 @@ let sty = buildStyle rsty initcolours sty modifyST $ \st -> st { config = sty } + else do + let sty = config emptySt + initcolours sty + modifyST $ \st -> st { config = sty } UI.resetui ------------------------------------------------------------------------ diff --git a/FastIO.hs b/FastIO.hs --- a/FastIO.hs +++ b/FastIO.hs @@ -28,23 +28,14 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B -import Data.Word (Word8) -import qualified Data.ByteString.UTF8 as UTF8 -import Foreign.C.Error -import Foreign.C.Types (CInt(..), CSize(..)) -import Foreign.Marshal (allocaBytes) -import Foreign.Ptr (Ptr, castPtr, plusPtr) -import Foreign.Storable (peekElemOff) -import Foreign.ForeignPtr +import System.Posix.Files.ByteString +import System.Posix.Directory.ByteString -import qualified System.Directory as Dir -import System.IO.Error (modifyIOError, ioeSetFileName) -import System.IO.Unsafe (unsafePerformIO) import System.IO (Handle,hFlush) import Data.IORef -import System.Posix.Internals -import Control.Exception (catch, SomeException) +import Control.Exception (catch, bracket, SomeException) +import Control.Monad.Extra (sequenceWhile) ------------------------------------------------------------------------ @@ -63,53 +54,32 @@ dirnameP :: P.ByteString -> P.ByteString dirnameP fps = case P.elemIndexEnd '/' fps of - Nothing -> P.pack "." + Nothing -> "." Just i -> P.take i fps {-# INLINE dirnameP #-} --- --- | Packed version of get directory contents --- Have them just return CStrings, then pack lazily? --- +-- | Packed version of listDirectory packedGetDirectoryContents :: P.ByteString -> IO [P.ByteString] -packedGetDirectoryContents = do - fmap (map UTF8.fromString) . Dir.listDirectory . UTF8.toString +packedGetDirectoryContents fp = bracket (openDirStream fp) closeDirStream + $ \ds -> fmap (filter (\p -> p/="." && p/="..")) + $ sequenceWhile (not . P.null) $ repeat $ readDirStream ds --- packed version: doesFileExist :: P.ByteString -> IO Bool -doesFileExist name = Control.Exception.catch - (packedWithFileStatus "Utils.doesFileExist" name $ \st -> do - b <- isDirectory st; return (not b)) +doesFileExist fp = catch + (not <$> isDirectory <$> getFileStatus fp) (\ (_ :: SomeException) -> return False) --- packed version: doesDirectoryExist :: P.ByteString -> IO Bool -doesDirectoryExist name = Control.Exception.catch - (packedWithFileStatus "Utils.doesDirectoryExist" name $ \st -> isDirectory st) +doesDirectoryExist fp = catch + (isDirectory <$> getFileStatus fp) (\ (_ :: SomeException) -> return False) -packedWithFileStatus :: String -> P.ByteString -> (Ptr CStat -> IO a) -> IO a -packedWithFileStatus loc name f = do - modifyIOError (`ioeSetFileName` []) $ - allocaBytes sizeof_stat $ \p -> do - B.useAsCString name $ \s -> do -- i.e. every string is duplicated - throwErrnoIfMinus1Retry_ loc (c_stat s p) - f p - packedFileNameEndClean :: P.ByteString -> P.ByteString packedFileNameEndClean name = - if i > 0 && (ec == '\\' || ec == '/') then - packedFileNameEndClean (P.take i name) - else - name - where - i = (P.length name) - 1 - ec = name `P.index` i - -isDirectory :: Ptr CStat -> IO Bool -isDirectory stat = do - mode <- st_mode stat - return (s_isdir mode) + case P.unsnoc name of + Just (name', ec) | ec == '\\' || ec == '/' + -> packedFileNameEndClean name' + _ -> name -- --------------------------------------------------------------------- @@ -130,55 +100,23 @@ -- --------------------------------------------------------------------- -getPermissions :: P.ByteString -> IO Dir.Permissions -getPermissions = Dir.getPermissions . UTF8.toString +isReadable :: P.ByteString -> IO Bool +isReadable fp = fileAccess fp True False False -- --------------------------------------------------------------------- -- | Send a msg over the channel to the decoder send :: Pretty a => Handle -> a -> IO () -send h m = P.hPut h (ppr m) >> P.hPut h nl >> hFlush h - where - nl = P.pack "\n" +send h m = P.hPut h (ppr m) >> P.hPut h "\n" >> hFlush h ------------------------------------------------------------------------ -- | 'dropSpaceEnd' efficiently returns the 'ByteString' argument with --- white space removed from the end. I.e. +-- white space removed from the end. I.e., -- -- > reverse . (dropWhile isSpace) . reverse == dropSpaceEnd --- --- but it is more efficient than using multiple reverses. --- dropSpaceEnd :: P.ByteString -> P.ByteString {-# INLINE dropSpaceEnd #-} -dropSpaceEnd (B.PS x s l) = unsafePerformIO $ withForeignPtr x $ \p -> do - i <- lastnonspace (p `plusPtr` s) (l-1) - return $! if i == (-1) then B.empty else B.PS x s (i+1) - where - lastnonspace :: Ptr Word8 -> Int -> IO Int - lastnonspace ptr n - | ptr `seq` n `seq` False = undefined - | n < 0 = return n - | otherwise = do w <- peekElemOff ptr n - if B.isSpaceWord8 w then lastnonspace ptr (n-1) - else return n - ------------------------------------------------------------------------- - --- --- A wrapper over printf for use in UI.PTimes --- -printfPS :: P.ByteString -> Int -> Int -> P.ByteString -printfPS fmt arg1 arg2 = - unsafePerformIO $ B.createAndTrim lim $ \ptr -> - B.useAsCString fmt $ \c_fmt -> do - sz' <- c_printf2d ptr (fromIntegral lim) (castPtr c_fmt) - (fromIntegral arg1) (fromIntegral arg2) - return (min lim (fromIntegral sz')) -- snprintf might truncate - where - lim = 10 -- NB - --- --------------------------------------------------------------------- +dropSpaceEnd bs = P.take (P.length bs - count) bs where + count = B.foldl' go 0 bs + go n c = if B.isSpaceWord8 c then n+1 else 0 -foreign import ccall unsafe "static stdio.h snprintf" - c_printf2d :: Ptr Word8 -> CSize -> Ptr Word8 -> CInt -> CInt -> IO CInt diff --git a/Keymap.hs b/Keymap.hs --- a/Keymap.hs +++ b/Keymap.hs @@ -44,7 +44,7 @@ import Data.List ((\\), find) -import qualified Data.ByteString.Char8 as P (ByteString, pack) +import qualified Data.ByteString.Char8 as P (ByteString, pack, singleton) import qualified Data.Map as M (fromList, lookup, Map) data Search = SearchFile | SearchDir @@ -82,12 +82,12 @@ searchDir :: LexerS searchDir = (char '\\' >|< char '|') `meta` \[c] _ -> - (with (toggleFocus >> putmsg (Fast (P.pack [c]) defaultSty) >> touchST) + (with (toggleFocus >> putmsg (Fast (P.singleton c) defaultSty) >> touchST) ,(SearchDir,if c == '\\' then Forwards else Backwards,[c]) ,Just dosearch) searchFile :: LexerS searchFile = (char '/' >|< char '?') `meta` \[c] _ -> - (with (toggleFocus >> putmsg (Fast (P.pack [c]) defaultSty) >> touchST) + (with (toggleFocus >> putmsg (Fast (P.singleton c) defaultSty) >> touchST) ,(SearchFile,if c == '/' then Forwards else Backwards,[c]) ,Just dosearch) dosearch :: LexerS @@ -150,72 +150,61 @@ keyTable :: [(P.ByteString, [Char], IO ())] keyTable = [ - (p "Move up", + ("Move up", ['k',unkey KeyUp], up) - ,(p "Move down", + ,("Move down", ['j',unkey KeyDown], down) - ,(p "Page down", + ,("Page down", [unkey KeyNPage], downPage) - ,(p "Page up", + ,("Page up", [unkey KeyPPage], upPage) - ,(p "Jump to start of list", + ,("Jump to start of list", [unkey KeyHome,'1'], jump 0) - ,(p "Jump to end of list", + ,("Jump to end of list", [unkey KeyEnd,'G'], jump maxBound) - ,(p "Seek left within song", + ,("Seek left within song", [unkey KeyLeft], seekLeft) - ,(p "Seek right within song", + ,("Seek right within song", [unkey KeyRight], seekRight) - ,(p "Toggle pause", + ,("Toggle pause", [' '], pause) - ,(p "Play song under cursor", + ,("Play song under cursor", ['\n'], play) - ,(p "Play previous track", + ,("Play previous track", ['K'], playPrev) - ,(p "Play next track", + ,("Play next track", ['J'], playNext) - ,(p "Toggle the help screen", + ,("Toggle the help screen", ['h'], toggleHelp) - ,(p "Jump to currently playing song", + ,("Jump to currently playing song", ['t'], jumpToPlaying) - ,(p "Quit (or close help screen)", + ,("Quit (or close help screen)", ['q'], do b <- helpIsVisible ; if b then toggleHelp else quit Nothing) - ,(p "Select and play next track", + ,("Select and play next track", ['d'], playNext >> jumpToPlaying) - ,(p "Cycle through normal, random and loop modes", + ,("Cycle through normal, random and loop modes", ['m'], nextMode) - ,(p "Refresh the display", + ,("Refresh the display", ['\^L'], UI.resetui) - ,(p "Repeat last regex search", + ,("Repeat last regex search", ['n'], jumpToMatchFile Nothing True) - ,(p "Repeat last regex search backwards", + ,("Repeat last regex search backwards", ['N'], jumpToMatchFile Nothing False) - ,(p "Play", + ,("Play", ['p'], playCur) - ,(p "Mark as deletable", + ,("Mark as deletable", ['d'], blacklist) - ,(p "Load config file", + ,("Load config file", ['l'], loadConfig) - ,(p "Restart song", + ,("Restart song", [unkey KeyBackspace], seekStart) ] - where - -- Keep as Addr#. If we try the pack/packAddress rule, ghc seems to get - -- confused and want to *unpack* the strings :/ - p = P.pack - {-# INLINE p #-} extraTable :: [(P.ByteString, [Char])] -extraTable = [(p "Search for file matching regex", ['/']) - ,(p "Search backwards for file", ['?']) - ,(p "Search for directory matching regex", ['\\']) - ,(p "Search backwards for directory", ['|']) ] - where - -- Keep as Addr#. If we try the pack/packAddress rule, ghc seems to get - -- confused and want to *unpack* the strings :/ - p = P.pack - {-# INLINE p #-} - +extraTable = [("Search for file matching regex", ['/']) + ,("Search backwards for file", ['?']) + ,("Search for directory matching regex", ['\\']) + ,("Search backwards for directory", ['|']) ] helpIsVisible :: IO Bool helpIsVisible = getsST helpVisible diff --git a/Lexer.hs b/Lexer.hs --- a/Lexer.hs +++ b/Lexer.hs @@ -81,13 +81,13 @@ , extension = read $ P.unpack $ fs !! 11 -} userinfo = P.concat - [P.pack "mpeg " + ["mpeg " ,fs !! 0 - ,P.pack " " + ," " ,fs !! 10 - ,P.pack "kbit/s " + ,"kbit/s " ,(P.pack . show) ((readPS (fs !! 2)) `div` 1000 :: Int) - ,P.pack "kHz"] + ,"kHz"] } -- Track info if ID fields are in the file, otherwise file name. @@ -95,8 +95,8 @@ doI :: P.ByteString -> Msg doI s = let f = dropSpaceEnd . P.dropWhile isSpace $ s in case P.take 4 f of - cs | cs == P.pack "ID3:" -> F . File . Right . toId id3 . splitUp . P.drop 4 $ f - | otherwise -> F . File . Left $ f + cs | cs == "ID3:" -> F . File . Right . toId id3 . splitUp . P.drop 4 $ f + | otherwise -> F . File . Left $ f where -- a default id3 :: Id3 @@ -134,7 +134,7 @@ maybeJoin t f = if P.null f then t `P.append` P.empty else t `gap` f - gap x y = P.concat [ x, (P.pack " : "), y ] + gap x y = P.concat [ x, " : ", y ] normalise = P.dropWhile isSpace . dropSpaceEnd diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -83,9 +83,9 @@ Nothing -> do mapM_ putStrLn usage; exitWith ExitSuccess Just st -> return $ Left st -do_args [s] | s == P.pack "-V" || s == P.pack "--version" +do_args [s] | s == "-V" || s == "--version" = do putStrLn (versinfo <+> help); putStrLn darcsinfo; exitWith ExitSuccess - | s == P.pack "-h" || s == P.pack "--help" + | s == "-h" || s == "--help" = do putStrLn (versinfo <+> help); mapM_ putStrLn usage; exitWith ExitSuccess do_args xs = return $ Right xs diff --git a/State.hs b/State.hs --- a/State.hs +++ b/State.hs @@ -34,7 +34,7 @@ import Data.Array (listArray) import System.IO.Unsafe (unsafePerformIO) import System.Posix.Types (ProcessID) -import System.Time (ClockTime(..)) +import System.Clock (TimeSpec(..)) import System.IO (Handle) import System.Random.Mersenne @@ -73,7 +73,7 @@ ,miniFocused :: !Bool -- is the mini buffer focused? ,mode :: !Mode -- random mode ,uptime :: !P.ByteString - ,boottime :: !ClockTime + ,boottime :: !TimeSpec ,regex :: !(Maybe (Regex,Bool)) -- most recent search pattern and direction ,xterm :: !Bool ,doNotResuscitate:: !Bool -- should we just let mpg321 die? @@ -117,7 +117,7 @@ ,doNotResuscitate = False -- mgp321 should be be restarted ,config = Config.defaultStyle - ,boottime = TOD 0 0 + ,boottime = TimeSpec 0 0 ,status = Stopped ,mode = Normal ,minibuffer = Fast P.empty defaultSty diff --git a/Syntax.hs b/Syntax.hs --- a/Syntax.hs +++ b/Syntax.hs @@ -38,7 +38,7 @@ data Load = Load {-# UNPACK #-} !P.ByteString instance Pretty Load where - ppr (Load f) = P.concat [P.pack "LOAD ", f] + ppr (Load f) = P.concat ["LOAD ", f] -- If '+' or '-' is specified, jumps frames forward, or backwards, -- respectively, in the the mp3 file. If neither is specifies, jumps to @@ -46,19 +46,19 @@ data Jump = Jump {-# UNPACK #-} !Int instance Pretty Jump where - ppr (Jump i) = P.concat [P.pack "JUMP ", P.pack . show $ i] + ppr (Jump i) = P.concat ["JUMP ", P.pack . show $ i] -- Pauses the playback of the mp3 file; if already paused, restarts playback. data Pause = Pause instance Pretty Pause where - ppr Pause = P.pack "PAUSE" + ppr Pause = "PAUSE" -- Quits mpg321. data Quit = Quit instance Pretty Quit where - ppr Quit = P.pack "QUIT" + ppr Quit = "QUIT" ------------------------------------------------------------------------ -- diff --git a/Tree.hs b/Tree.hs --- a/Tree.hs +++ b/Tree.hs @@ -39,7 +39,6 @@ import Data.List (sortBy,sort,foldl',groupBy) import System.IO (hPutStrLn,stderr) -import System.Directory (Permissions(readable)) import Control.Exception(handle, SomeException) import Control.Monad (liftM) @@ -138,9 +137,9 @@ validFiles p = notEdge p onlyMp3s p = mp3 == (P.map toLower . P.drop (P.length p -3) $ p) - mp3 = P.pack "mp3" - dot = P.pack "." - dotdot = P.pack ".." + mp3 = "mp3" + dot = "." + dotdot = ".." -- -- | Given an the next index into the files array, a directory name, and @@ -165,7 +164,7 @@ partition (a:xs) = do (fs,ds) <- partition xs x <- doesFileExist a - if x then do y <- getPermissions a >>= return . readable + if x then do y <- isReadable a return $! if y then (a:fs, ds) else (fs, ds) else return (fs, a:ds) diff --git a/UI.hs b/UI.hs --- a/UI.hs +++ b/UI.hs @@ -40,7 +40,7 @@ import Style import Utils (isLightBg) -import FastIO (basenameP, printfPS) +import FastIO (basenameP) import Tree (File(fdir, fbase), Dir(dname)) import State import Syntax @@ -48,7 +48,7 @@ import qualified UI.HSCurses.Curses as Curses import {-# SOURCE #-} Keymap (extraTable, keyTable, unkey, charToKey) -import Data.List (intersperse,isPrefixOf) +import Data.List (isPrefixOf) import Data.Array ((!), bounds, Array, listArray) import Data.Array.Base (unsafeAt) import Control.Monad (when, void) @@ -56,14 +56,10 @@ import System.IO (stderr, hFlush) import System.Posix.Signals (raiseSignal, sigTSTP, installHandler, Handler(..)) import System.Posix.Env (getEnv, putEnv) +import Text.Printf import qualified Data.ByteString.Char8 as P -import qualified Data.ByteString as B - -import Foreign.C.Types (CInt(..)) -import Foreign.C.String (CString) - --- import qualified Data.ByteString.UTF8 as UTF8 +import qualified Data.ByteString.UTF8 as UTF8 ------------------------------------------------------------------------ @@ -112,7 +108,7 @@ -- | Clean up and go home. Refresh is needed on linux. grr. -- end :: Bool -> IO () -end isXterm = do when isXterm $ setXtermTitle [P.pack "xterm"] +end isXterm = do when isXterm $ setXtermTitle ["xterm"] Curses.endWin -- @@ -254,7 +250,7 @@ Just i -> userinfo i emptyVal :: P.ByteString -emptyVal = P.pack "(empty)" +emptyVal = "(empty)" spc2 :: P.ByteString spc2 = spaces 2 @@ -270,16 +266,15 @@ f :: [Char] -> P.ByteString -> P.ByteString f cs ps = - let p = P.pack str `P.append` ps + let p = str `P.append` ps s = P.pack (take (tot - P.length p) (repeat ' ')) in p `P.append` s where tot = round $! fromIntegral w * (0.8::Float) len = round $! fromIntegral tot * (0.2::Float) - -- faststringify - str = take len $ ' ' : - (concat . intersperse " " $ (map pprIt cs)) ++ repeat ' ' + str = P.take len $ P.intercalate " " + ([""] ++ map pprIt cs ++ [P.replicate len ' ']) pprIt c = case c of '\n' -> "Enter" @@ -295,7 +290,7 @@ Curses.KeyEnd -> "End" Curses.KeyHome -> "Home" Curses.KeyBackspace -> "Backspace" - _ -> show c + _ -> P.pack $ show c ------------------------------------------------------------------------ @@ -308,10 +303,8 @@ ,(gap, defaultSty) ,(remaining,defaultSty)] where - elapsed = printfPS fmt1 lm lm' - remaining = printfPS fmt2 rm rm' - fmt1 = P.pack "%01d:%02d" - fmt2 = P.pack "-%01d:%02d" + elapsed = P.pack $ printf "%d:%02d" lm lm' + remaining = P.pack $ printf "-%d:%02d" rm rm' (lm,lm') = quotRem (fst . currentTime $ fr) 60 (rm,rm') = quotRem (fst . timeLeft $ fr) 60 gap = spaces distance @@ -361,9 +354,9 @@ Paused -> b Playing -> c - where a = P.pack "stop" - b = P.pack "pause" - c = P.pack "play" + where a = "stop" + b = "pause" + c = "play" -- | Loop, normal or random instance Element PMode2 where @@ -372,9 +365,9 @@ Loop -> b Normal -> c - where a = P.pack "random" - b = P.pack "loop" - c = P.empty + where a = "random" + b = "loop" + c = "" ------------------------------------------------------------------------ @@ -388,22 +381,22 @@ instance Element PlayInfo where draw _ _ st _ = PlayInfo $ P.concat [percent - ,P.pack " (" + , " (" ,P.pack (show (1 + ( snd . bounds . folders $ st))) - ,P.pack " dir" + , " dir" ,if (snd . bounds $ folders st) == 1 then P.empty else plural - ,P.pack ", " + , ", " ,P.pack (show . size $ st) - ,P.pack " file" + , " file" ,if size st == 1 then P.empty else plural - ,P.pack ")"] + , ")"] where - plural = P.pack "s" -- expose to inlining - pct = P.pack "%" + plural = "s" -- expose to inlining + pct = "%" curr = cursor st - percent | percent' == 0 && curr == 0 = P.pack "top" - | percent' == 100 = P.pack "all" + percent | percent' == 0 && curr == 0 = "top" + | percent' == 100 = "all" | otherwise = if P.length s == 2 then ' ' `P.cons` s else s where s = P.pack (show percent') `P.append` pct @@ -509,7 +502,7 @@ post = (b, sty) d = basenameP $ case size st of - 0 -> P.pack "(empty)" + 0 -> "(empty)" _ -> dname $ folders st ! i spc = spaces (indent - P.length d) @@ -560,7 +553,7 @@ s100 = P.replicate 100 ' ' -- seems reasonable ellipsis :: P.ByteString -ellipsis = P.pack "... " +ellipsis = "... " {-# INLINE ellipsis #-} ------------------------------------------------------------------------ @@ -646,19 +639,14 @@ where loop [] = return () loop ((l,sty):xs) = drawPackedString l sty >> loop xs --- worker +-- much less efficient than before, could drop into FFI if pure ascii drawPackedString :: P.ByteString -> Style -> IO () drawPackedString ps sty = - withStyle sty $ B.useAsCString (P.map asAscii ps) $ \cstr -> - Curses.throwIfErr_ msg $ - waddnstr Curses.stdScr - -- Curses.wAddStr Curses.stdScr - -- UTF8.toString ps - cstr (fromIntegral . P.length $ ps) - where - msg = "drawPackedString" - asAscii x | x >= ' ' && x < '\127' = x - | otherwise = '*' + 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 ------------------------------------------------------------------------ @@ -704,8 +692,8 @@ mapM_ (P.hPut stderr) (before : strs ++ [after]) hFlush stderr where - before = P.pack "\ESC]0;" - after = P.pack "\007" + before = "\ESC]0;" + after = "\007" ------------------------------------------------------------------------ @@ -716,15 +704,11 @@ if status s == Playing then case id3 s of Nothing -> case size s of - 0 -> [P.pack "hmp3"] + 0 -> ["hmp3"] _ -> [(fbase $ music s ! current s)] Just ti -> id3artist ti : if P.null (id3title ti) then [] - else [P.pack ": ", id3title ti] + else [": ", id3title ti] else let (PMode pm) = draw sz (0,0) s f :: PMode in [pm] - --- Not exported by hscurses. -foreign import ccall safe - waddnstr :: Curses.Window -> CString -> CInt -> IO CInt diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -33,12 +33,11 @@ module Utils where -import FastIO (printfPS) -import qualified Data.ByteString.Char8 as P (pack) import qualified Data.ByteString as P (ByteString) +import qualified Data.ByteString.Char8 as P (pack) import Data.Char (toLower) -import System.Time (diffClockTimes, TimeDiff(tdSec), ClockTime) +import System.Clock (TimeSpec(..), diffTimeSpec) import System.Environment (getEnv) import System.Posix.Types (Fd(..),ProcessID) import System.Process.Internals (mkProcessHandle,ProcessHandle) @@ -49,6 +48,7 @@ import Control.Exception (handle, SomeException) import System.IO.Unsafe (unsafePerformIO) +import Text.Printf (printf) ------------------------------------------------------------------------ @@ -67,16 +67,16 @@ ------------------------------------------------------------------------ -drawUptime :: ClockTime -> ClockTime -> P.ByteString -drawUptime before now = - let r = diffClockTimes now before - s = tdSec r - (h,sr) = quotRem s (60 * 60) - m = quot sr 60 - in printfPS fmt h m - where - fmt = P.pack "%3dh%02dm" -- sometimes ghc doesn't want to fire a RULE here, why? - -- its crucial for snprintf that this is unpacked +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 ------------------------------------------------------------------------ -- | Repeat an action 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.4.2 +version: 2.5.1 homepage: https://github.com/galenhuntington/hmp3-ng license: GPL license-file: LICENSE @@ -31,12 +31,13 @@ bytestring >= 0.10, containers, array, - old-time, + clock, directory, process, utf8-string, hscurses, - mtl + mtl, + monad-extras ghc-options: -Wall -funbox-strict-fields -threaded -Wno-unused-do-bind main-is: Main.hs @@ -44,5 +45,4 @@ Lexer Lexers State Style Syntax Tree UI Utils Paths_hmp3_ng - extensions: CPP, ForeignFunctionInterface, ScopedTypeVariables - extra-libraries: curses + extensions: ScopedTypeVariables, OverloadedStrings