hmp3-ng 2.11.0 → 2.12.0
raw patch · 10 files changed
+236/−133 lines, 10 filesdep −monad-extras
Dependencies removed: monad-extras
Files
- Base.hs +27/−2
- Config.hs +4/−4
- Core.hs +60/−23
- FastIO.hs +0/−1
- Keymap.hs +32/−9
- Keymap.hs-boot +2/−3
- State.hs +6/−1
- Style.hs +6/−7
- UI.hs +95/−78
- hmp3-ng.cabal +4/−5
Base.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE CPP #-}+ ----- Copyright (c) 2020 Galen Huntington+-- Copyright (c) 2020, 2021 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@@ -17,7 +19,7 @@ -- 02111-1307, USA. -- -module Base (module Prelude, module X) where+module Base (module Prelude, module X, module Base) where import Prelude @@ -44,4 +46,27 @@ import System.IO as X (Handle, hClose) import System.IO.Unsafe as X import Text.Printf as X+import System.Clock+++-- Random utility functions.++discardErrors :: IO () -> IO ()+discardErrors = X.handle @SomeException (\_ -> pure ())++whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenJust mval f = case mval of Nothing -> pure (); Just v -> f v++getMonoTime :: IO TimeSpec+getMonoTime = getTime+#if linux_HOST_OS+ Boottime+#else+ Monotonic+#endif++sequenceWhile :: Monad m => (a -> Bool) -> [m a] -> m [a]+sequenceWhile _ [] = pure []+sequenceWhile p (m:ms) = m >>= \a ->+ if p a then (a:) <$> sequenceWhile p ms else pure []
Config.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-2021 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@@ -30,7 +30,7 @@ , cursors = Style black cyan , combined = Style brightwhite cyan , warnings = Style red defaultbg- , helpscreen = Style black white+ , modal = Style black white , blockcursor= Style black red , progress = Style cyan white } @@ -50,7 +50,7 @@ , cursors = Style black cyan , combined = Style black cyan , warnings = Style brightwhite red- , helpscreen = Style black cyan+ , modal = Style black cyan , blockcursor= Style black darkred , progress = Style cyan white } @@ -62,7 +62,7 @@ ,cursors = Style reversefg reversebg ,combined = Style reversefg reversebg ,warnings = Style reversefg reversebg- ,helpscreen = Style reversefg reversebg+ ,modal = Style reversefg reversebg ,blockcursor = Style reversefg reversebg ,progress = Style reversefg reversebg }
Core.hs view
@@ -32,10 +32,12 @@ upPage, downPage, seekStart, blacklist,+ showHist, hideHist, writeSt, readSt, jumpToMatch, jumpToMatchFile, toggleFocus, jumpToNextDir, jumpToPrevDir, loadConfig,+ discardErrors, FileListSource, ) where @@ -54,14 +56,17 @@ import {-# SOURCE #-} Keymap (keymap) import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.Sequence as Seq import Data.Array ((!), bounds, Array) import System.Directory (doesFileExist,findExecutable) import System.IO (hPutStrLn, hGetLine, stderr, hFlush) import System.Process (runInteractiveProcess, waitForProcess)-import System.Clock (getTime, TimeSpec(..), Clock(..), diffTimeSpec)+import System.Clock (TimeSpec(..), diffTimeSpec) import System.Random (randomIO) import System.FilePath ((</>))+import Data.List (isInfixOf, tails) import System.Posix.Process (exitImmediately) import System.Posix.User (getUserEntryForID, getRealUserID, homeDirectory)@@ -96,7 +101,7 @@ ,ser_indx st ,ser_mode st) - now <- getTime Monotonic+ now <- getMonoTime -- fork some threads t1 <- forkIO $ mpgInput readf@@ -114,7 +119,7 @@ , cursor = i , current = i , mode = m- , uptime = showUptime now now+ , uptime = showTimeDiff now now , boottime = now , config = c , threads = [t0,t1,t2,t3,t4,t5] }@@ -206,24 +211,31 @@ uptimeLoop :: IO () uptimeLoop = runForever $ do threadDelay delay- now <- getTime Monotonic- modifyST $ \st -> st { uptime = showUptime (boottime st) now }+ now <- getMonoTime+ modifyST $ \st -> st { uptime = showTimeDiff (boottime st) now } where 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+showTimeDiff_ :: Bool -> TimeSpec -> TimeSpec -> ByteString+showTimeDiff_ secs before now+ | ms == 0 && secs+ = go ""+ | hs == 0 = go $ printf "%dm" m+ | d == 0 = go $ printf "%dh%02dm" h m+ | True = go $ printf "%dd%02dh%02dm" d h m where- s = sec $ diffTimeSpec before now- ms = quot s 60+ go = P.pack . ss+ stot = sec $ diffTimeSpec before now+ (ms,s) = quotRem stot 60 (hs,m) = quotRem ms 60 (d,h) = quotRem hs 24+ ss = if secs then (<> printf (if ms > 0 then "%02ds" else "%ds") s) else id +showTimeDiff :: TimeSpec -> TimeSpec -> ByteString+showTimeDiff = showTimeDiff_ False+ ------------------------------------------------------------------------ -- | Once each half second, wake up a and redraw the clock@@ -275,7 +287,7 @@ shutdown :: Maybe String -> IO () shutdown ms = do silentlyModifyST $ \st -> st { doNotResuscitate = True }- handle @SomeException (\_ -> pure ()) writeSt+ discardErrors writeSt withST $ \st -> do case mp3pid st of Nothing -> pure ()@@ -368,6 +380,7 @@ pure st { cursor = floor $ fromIntegral (size st) * r } -- | Generic jump+-- TODO why is this in IO? jumpTo :: HState -> (Int -> Int) -> IO HState jumpTo st fn = do let l = max 0 (size st - 1)@@ -417,11 +430,10 @@ if md == Random then playRandom else modifySTM $ \st -> do let i = current st- case () of {_+ if | i > 0 -> playAtN st (subtract 1) -- just the prev track | mode st == Loop -> playAtN st (const (size st - 1)) -- maybe loop | otherwise -> pure st -- else stop at end- } -- | Play the song following the current song, if we're not at the end -- If we're at the end, and loop mode is on, then loop to the start@@ -432,26 +444,29 @@ if md == Random then playRandom else modifySTM $ \st -> do let i = current st- case () of {_+ if | i < size st - 1 -> playAtN st (+ 1) -- just the next track | mode st == Loop -> playAtN st (const 0) -- maybe loop | otherwise -> pure st -- else stop at end- } -- | Generic next song selection -- If the cursor and current are currently the same, continue that. playAtN :: HState -> (Int -> Int) -> IO HState playAtN st fn = do+ now <- getMonoTime let m = music st i = current st- fe = m ! fn i+ new = fn i+ fe = m ! new -- unsure of this GBH (2008) f = P.intercalate (P.singleton '/') [dname $ folders st ! fdir fe, fbase fe] j = cursor st- st' = st { current = fn i+ st' = st { current = new , status = Playing- , cursor = if i == cursor st then fn i else j }+ , cursor = if i == cursor st then new else j+ , playHist = Seq.take 36 $ (now, new) Seq.<| playHist st+ } h <- readMVar (writeh st) send h (Load f) pure st'@@ -521,7 +536,7 @@ Nothing -> case regex st of Nothing -> Nothing Just (r,d) -> Just (r,d==sw)- Just s -> case compileM (P.pack s) [caseless] of+ Just s -> case compileM (P.pack s) [caseless,utf8] of Left _ -> Nothing Right v -> Just (v,sw) case mre of@@ -546,7 +561,7 @@ -- mi <- if forwards then loop (>=m) (+1) (cur+1) -- else loop (<0) (subtract 1) (cur-1)- mi <- fmap msum $ mapM check $+ mi <- fmap msum $ traverse check $ if forwards then [cur+1..m-1] ++ [0..cur] else [cur-1,cur-2..0] ++ [m-1,m-2..cur] @@ -568,6 +583,20 @@ toggleFocus :: IO () toggleFocus = modifyST $ \st -> st { miniFocused = not (miniFocused st) } +-- | History on or off+hideHist :: IO ()+hideHist = modifyST $ \st -> st { histVisible = Nothing }+showHist :: IO ()+showHist = do+ now <- getMonoTime+ modifyST $ \st -> st {+ helpVisible = False,+ histVisible = Just $ do+ (tm, ix) <- toList $ playHist st+ pure (UTF8.toString $ showTimeDiff_ True tm now+ , UTF8.toString $ fbase $ music st ! ix)+ }+ -- | Toggle the mode flag nextMode :: IO () nextMode = modifyST $ \st -> st { mode = next (mode st) }@@ -618,7 +647,14 @@ let f = home </> ".hmp3" b <- doesFileExist f if b then do- str <- readFile f+ str' <- readFile f+ str <- let (old, new) = ("hmp3_helpscreen", "hmp3_modal") in+ if old `isInfixOf` str'+ then do+ warnA $ old ++ " is now " ++ new ++ " in ~/.hmp3"+ let (ix, rest) = head $ filter (\ (_, s) -> old `isPrefixOf` s) $ zip [0..] $ tails str'+ pure $ take ix str' ++ new ++ drop (length old) rest+ else pure str' msty <- catch (fmap Just $ evaluate $ read str) (\ (_ :: SomeException) -> warnA "Parse error in ~/.hmp3" $> Nothing)@@ -649,3 +685,4 @@ warnA x = do sty <- getsST config putmsg $ Fast (P.pack x) (warnings sty)+
FastIO.hs view
@@ -34,7 +34,6 @@ import System.Posix.Directory.ByteString import System.IO (hFlush)-import Control.Monad.Extra (sequenceWhile) ------------------------------------------------------------------------
Keymap.hs view
@@ -36,7 +36,7 @@ import Base hiding (all) import Core-import State (getsST, touchST, HState(helpVisible))+import State (getsST, touchST, HState(helpVisible, playHist)) import Style (defaultSty, StringA(Fast)) import qualified UI (resetui) import Lexers ((>||<),action,meta,execLexer@@ -46,6 +46,7 @@ import qualified Data.ByteString.Char8 as P import qualified Data.Map as M+import qualified Data.Sequence as Seq data Direction = Forwards | Backwards data Zipper = Zipper { cur :: !String, back :: ![String], front :: ![String] }@@ -76,7 +77,7 @@ where (actions,_,_) = execLexer all (cs, SearchState [] undefined) all :: LexerS-all = commands >||< search+all = commands >||< search >||< history commands :: LexerS commands = alt keys `action` \[c] -> Just $ fromMaybe (pure ()) $ M.lookup c keyMap@@ -147,16 +148,37 @@ [] -> endSearchWith (clrmsg *> touchST) hist pat -> let typ = schType spec- jumpTo = case schWhat typ of+ jumpy = case schWhat typ of SearchFiles -> jumpToMatchFile SearchDirs -> jumpToMatch in endSearchWith- do jumpTo (Just pat) case schDir typ of Forwards -> True; _ -> False+ do jumpy (Just pat) case schDir typ of Forwards -> True; _ -> False do if take 1 hist == [pat] then hist else pat : hist ------------------------------------------------------------------------ +history :: LexerS+history = alt ['H', ';'] `meta`+ \_ st -> (with (showHist *> touchST), st, Just inner) where+ inner =+ alt any' `meta` (\_ st -> (with (hideHist *> touchST), st, Just all))+ >||< alt ['0'..'9'] `meta` handleKey '0' 0+ >||< alt ['a'..'z'] `meta` handleKey 'a' 10+ handleKey base off cs st =+ (with do+ ph <- getsST playHist+ whenJust+ do ph Seq.!? (fromEnum (head cs) - (fromEnum base - off))+ do jump . snd+ hideHist+ touchST+ , st+ , Just all+ )++------------------------------------------------------------------------+ -- "Key"s seem to be inscrutable and incomparable. -- Solution is to translate to chars. Really hacky! -- TODO at least use lookup table (standalone deriving Ord)@@ -181,7 +203,7 @@ -- -- The default keymap, and its description ---keyTable :: [(ByteString, [Char], IO ())]+keyTable :: [(String, [Char], IO ())] keyTable = [ ("Move up",@@ -228,8 +250,8 @@ ['N'], jumpToMatchFile Nothing False) ,("Play", ['p'], playCur)- ,("Mark as deletable",- ['d'], blacklist)+ ,("Mark for deletion in ~/.hmp3-delete",+ ['D'], blacklist) ,("Load config file", ['l'], loadConfig) ,("Restart song",@@ -239,8 +261,9 @@ innerTable :: [(Char, IO ())] innerTable = [(c, jumpRel i) | (i, c) <- zip [0.1, 0.2 ..] ['1'..'9']] -extraTable :: [(ByteString, [Char])]-extraTable = [("Search for file matching regex", ['/'])+extraTable :: [(String, [Char])]+extraTable = [("Toggle the song history", ['H', ';'])+ ,("Search for file matching regex", ['/']) ,("Search backwards for file", ['?']) ,("Search for directory matching regex", ['\\']) ,("Search backwards for directory", ['|']) ]
Keymap.hs-boot view
@@ -1,11 +1,10 @@ module Keymap where -import Base import UI.HSCurses.Curses (Key) keymap :: [Char] -> [IO ()] -keyTable :: [(ByteString, [Char], IO ())]-extraTable :: [(ByteString, [Char])]+keyTable :: [(String, [Char], IO ())]+extraTable :: [(String, [Char])] unkey :: Key -> Char charToKey :: Char -> Key
State.hs view
@@ -33,6 +33,7 @@ import Text.Regex.PCRE.Light (Regex) import Data.Array (listArray)+import Data.Sequence (Seq) import System.Clock (TimeSpec(..)) import System.Process (ProcessHandle) @@ -63,13 +64,15 @@ ,status :: !Status ,minibuffer :: !StringA -- contents of minibuffer ,helpVisible :: !Bool -- is the help window shown+ ,histVisible :: !(Maybe [(String, String)]) -- history pop-up if shown ,miniFocused :: !Bool -- is the mini buffer focused? ,mode :: !Mode -- random mode ,uptime :: !ByteString ,boottime :: !TimeSpec ,regex :: !(Maybe (Regex,Bool)) -- most recent search pattern and direction ,xterm :: !Bool- ,doNotResuscitate:: !Bool -- should we just let mpg321 die?+ ,doNotResuscitate :: !Bool -- should we just let mpg321 die?+ ,playHist :: Seq (TimeSpec, Int) -- limited history of songs played ,config :: !UIStyle -- config values ,modified :: !(MVar ()) -- Set when redrawable components of @@ -105,10 +108,12 @@ ,clockUpdate = False ,helpVisible = False+ ,histVisible = Nothing ,miniFocused = False ,xterm = False ,doNotResuscitate = False -- mpg321 should be restarted + ,playHist = mempty ,config = Config.defaultStyle ,boottime = 0 ,status = Stopped
Style.hs view
@@ -1,6 +1,6 @@ -- -- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019, 2020 Galen Huntington+-- Copyright (c) 2019-2021 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@@ -35,7 +35,7 @@ -- for an item in the ui data UIStyle = UIStyle { window :: !Style -- default window colour- , helpscreen :: !Style -- help screen+ , modal :: !Style -- help screen , titlebar :: !Style -- titlebar of window , selected :: !Style -- currently playing track , cursors :: !Style -- the scrolling cursor line@@ -150,7 +150,7 @@ -- initcolours :: UIStyle -> IO () initcolours sty = do- let ls = [helpscreen sty, warnings sty, window sty, + let ls = [modal sty, warnings sty, window sty, selected sty, titlebar sty, progress sty, blockcursor sty, cursors sty, combined sty ] (Style fg bg) = progress sty -- bonus style@@ -176,8 +176,7 @@ fn :: Style -> Int -> IO (Style, (Curses.Attr,Curses.Pair)) fn sty p = do let (CColor (a,fgc),CColor (b,bgc)) = style2curses sty- handle @SomeException (\_ -> pure ()) $- Curses.initPair (Curses.Pair p) fgc bgc+ discardErrors $ Curses.initPair (Curses.Pair p) fgc bgc pure (sty, (a `Curses.attrPlus` b, Curses.Pair p)) ------------------------------------------------------------------------@@ -310,7 +309,7 @@ -- data Config = Config { hmp3_window :: (String,String)- , hmp3_helpscreen :: (String,String)+ , hmp3_modal :: (String,String) , hmp3_titlebar :: (String,String) , hmp3_selected :: (String,String) , hmp3_cursors :: (String,String)@@ -327,7 +326,7 @@ buildStyle :: Config -> UIStyle buildStyle bs = UIStyle { window = f $ hmp3_window bs- , helpscreen = f $ hmp3_helpscreen bs+ , modal = f $ hmp3_modal bs , titlebar = f $ hmp3_titlebar bs , selected = f $ hmp3_selected bs , cursors = f $ hmp3_cursors bs
UI.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE ForeignFunctionInterface, TupleSections #-}+{-# LANGUAGE ForeignFunctionInterface, TupleSections, AllowAmbiguousTypes #-} -- -- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2019, 2020 Galen Huntington+-- Copyright (c) 2019-2021 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@@ -54,6 +54,7 @@ import Data.Array ((!), bounds, Array, listArray) import Data.Array.Base (unsafeAt)+import Data.List (intercalate) import System.IO (stderr, hFlush) import System.Posix.Signals (raiseSignal, sigTSTP, installHandler, Handler(..)) @@ -79,7 +80,7 @@ -- start :: IO UIStyle start = do- handle @SomeException (\_ -> pure ()) do+ discardErrors do thisterm <- lookupEnv "TERM" case thisterm of Just "vt220" -> setEnv "TERM" "xterm-color"@@ -107,13 +108,11 @@ -- | Reset resetui :: IO ()-resetui = runDraw (resizeui <> nocursor) >> refresh+resetui = runDraw (resizeui <> nocursor) *> refresh -- | And force invisible nocursor :: Draw-nocursor = Draw do- handle @SomeException (\_ -> pure ()) $- void $ Curses.cursSet Curses.CursorInvisible+nocursor = Draw $ discardErrors $ void $ Curses.cursSet Curses.CursorInvisible -- -- | Clean up and go home. Refresh is needed on linux. grr.@@ -228,8 +227,13 @@ newtype PlayTitle = PlayTitle StringA newtype PlayInfo = PlayInfo ByteString newtype PlayModes = PlayModes String-newtype HelpScreen = HelpScreen [StringA] +data HelpScreen+data HistScreen+class ModalElement a where+ -- takes style, window width, state; returns (width, list of lines)+ drawModal :: Style -> Int -> HState -> Maybe (Int, [StringA])+ ------------------------------------------------------------------------ instance Element PlayScreen where@@ -257,8 +261,8 @@ 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+ line | gap >= 0 = U s : (B $ spaces gap) : right+ | True = U (ellipsize lim s) : right where lim = x - 5 - (if showId3 then P.length b else -1) gap = lim - displayWidth s showId3 = x > 59@@ -284,45 +288,53 @@ spc2 :: AmbiString spc2 = B $ spaces 2 +modalWidth :: Int -> Int+modalWidth w = max (min w 3) $ round $ fromIntegral w * (0.8::Float)+ ------------------------------------------------------------------------ -instance Element HelpScreen where- 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+-- instance ModalElement me => Element (Modal me) where draw = drawModal - f :: [Char] -> ByteString -> ByteString- f cs ps =- let p = str <> ps- rt = tot - P.length p- in if rt > 0- then p <> spaces rt- else P.take (tot - 1) p <> UTF8.fromString "…"- where- tot = max (min w 3) $ round $ fromIntegral w * (0.8::Float)- len = max 2 $ round $ fromIntegral tot * (0.2::Float)+instance ModalElement HelpScreen where+ drawModal sty swd st = do+ guard $ helpVisible st+ pure $ (wd,) $+ [ Fast (f cs h) sty | (h,cs,_) <- keyTable ] +++ [ Fast (f cs h) sty | (h,cs) <- extraTable ]+ where+ wd = modalWidth swd+ f :: [Char] -> String -> ByteString+ f cs ps = UTF8.fromString $ forceWidth wd+ $ forceWidth clen cmds <> ps where+ clen = max 4 $ round $ fromIntegral wd * (0.2::Float)+ cmds = intercalate " " $ "" : map pprIt cs+ pprIt c = case c of+ '\n' -> "Enter"+ '\f' -> "^L"+ '\\' -> "\\"+ ' ' -> "Space"+ _ -> case charToKey c of+ Curses.KeyUp -> "↑"+ Curses.KeyDown -> "↓"+ Curses.KeyPPage -> "PgUp"+ Curses.KeyNPage -> "PgDn"+ Curses.KeyLeft -> "←"+ Curses.KeyRight -> "→"+ Curses.KeyEnd -> "End"+ Curses.KeyHome -> "Home"+ Curses.KeyBackspace -> "Backspace"+ _ -> [c] - str = P.take len $ P.intercalate " "- ([""] ++ map pprIt cs ++ [P.replicate len ' '])+------------------------------------------------------------------------ - pprIt c = case c of- '\n' -> "Enter"- '\f' -> "^L"- '\\' -> "\\"- ' ' -> "Space"- _ -> case charToKey c of- Curses.KeyUp -> "Up"- Curses.KeyDown -> "Down"- Curses.KeyPPage -> "PgUp"- Curses.KeyNPage -> "PgDn"- Curses.KeyLeft -> "Left"- Curses.KeyRight -> "Right"- Curses.KeyEnd -> "End"- Curses.KeyHome -> "Home"- Curses.KeyBackspace -> "Backspace"- _ -> P.singleton c+instance ModalElement HistScreen where+ drawModal sty swd st = flip fmap (histVisible st) \hist -> do+ let wd = modalWidth swd+ mtlen = maximum $ map (length . fst) hist+ tlen = min (mtlen + 1) $ wd `div` 3+ (wd,) $ flip map (zip (['0'..'9']++['a'..'z']) hist) \ (c, (time, song)) ->+ let tstr = ellipsize tlen $ replicate (tlen - displayWidth time) ' ' ++ time+ in Fast (UTF8.fromString $ forceWidth wd $ ' ' : c : ' ' : tstr ++ ' ' : song) sty ------------------------------------------------------------------------ @@ -556,48 +568,48 @@ -- Speed things up a bit, just use read State. -- redrawJustClock :: Draw-redrawJustClock = Draw do- handle @SomeException (\_ -> pure ()) do-+redrawJustClock = Draw $ discardErrors do st <- getsST id let fr = clock st (h, w) <- screenSize- let s = Size h w- let (ProgressBar bar) = draw $ DD s undefined st fr :: ProgressBar+ let sz = Size h w+ let (ProgressBar bar) = draw $ DD sz undefined st fr :: ProgressBar (PTimes times) = {-# SCC "redrawJustClock.times" #-}- draw $ DD s undefined st fr :: PTimes+ draw $ DD sz undefined st fr :: PTimes Curses.wMove Curses.stdScr 1 0 -- hardcoded! drawLine w bar Curses.wMove Curses.stdScr 2 0 -- hardcoded! drawLine w times- drawHelp st fr s+ when (h<45) $ renderModals st sz -- small screen modals paint over clock ------------------------------------------------------------------------ -- -- work for drawing help. draw the help screen if it is up ---drawHelp :: HState -> Maybe Frame -> Size -> IO ()-drawHelp st fr s@(Size h w) =- when (helpVisible st) $ do- 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- height = (h - length help') `div` 2- when (height > 0) $ do- Curses.wMove Curses.stdScr ((h - length help') `div` 2) offset- mapM_ (\t -> do drawLine w t- (y',_) <- Curses.getYX Curses.stdScr- Curses.wMove Curses.stdScr (y'+1) offset) help'+renderModal :: forall me. ModalElement me => HState -> Size -> IO ()+renderModal st (Size h w) = do+ whenJust (drawModal @me (modal $ config st) w st) \(mw, modal') -> do+ let hoffset = max 0 $ (w - mw) `div` 2+ mlines = min h $ length modal'+ voffset = (h - mlines) `div` 2+ Curses.wMove Curses.stdScr voffset hoffset+ for_ (take mlines modal') \t -> do+ drawLine w t+ (y',_) <- Curses.getYX Curses.stdScr+ Curses.wMove Curses.stdScr (y'+1) hoffset +renderModals :: HState -> Size -> IO ()+renderModals s sz = do+ renderModal @HelpScreen s sz+ renderModal @HistScreen s sz+ ------------------------------------------------------------------------ -- -- | Draw the screen -- redraw :: Draw-redraw = Draw $+redraw = Draw $ discardErrors do -- linux ncurses, in particular, seems to complain a lot. this is an easy solution- handle @SomeException (\_ -> pure ()) do- s <- getsST id -- another refresh could be triggered? let f = clock s (h, w) <- screenSize@@ -610,12 +622,12 @@ when (xterm s) $ setXterm s gotoTop- mapM_ (\t -> do drawLine w t- (y, x) <- Curses.getYX Curses.stdScr- fillLine- maybeLineDown t h y x )- (take (h-1) (init a))- drawHelp s f sz+ for_ (take (h-1) (init a)) \t -> do+ drawLine w t+ (y, x) <- Curses.getYX Curses.stdScr+ fillLine+ maybeLineDown t h y x+ renderModals s sz -- minibuffer Curses.wMove Curses.stdScr (h-1) 0@@ -659,7 +671,7 @@ -- | Fill to end of line spaces -- fillLine :: IO ()-fillLine = handle @SomeException (\_ -> pure ()) Curses.clrToEol -- harmless?+fillLine = discardErrors Curses.clrToEol -- harmless? -- -- | move cursor to origin of stdScr.@@ -685,7 +697,7 @@ -- setXtermTitle :: [ByteString] -> IO () setXtermTitle strs = do- mapM_ (P.hPut stderr) (before : strs ++ [after])+ traverse_ (P.hPut stderr) (before : strs ++ [after]) hFlush stderr where before = "\ESC]0;"@@ -711,16 +723,21 @@ displayWidth :: String -> Int displayWidth = sum . map charWidth -ellipsize :: Int -> String -> String-ellipsize w s- | displayWidth s <= w = s- | True = go 0 0 s where+sizer :: Bool -> Int -> String -> String+sizer pad w s+ | dw <= w = if pad then s ++ replicate (w - dw) ' ' else s+ | True = go 0 0 s where go !i !l (c:s') = if l' > w-1 then take i s ++ replicate (w-l) '…' else go (i+1) l' s' where l' = l + charWidth c go _ _ _ = error "Should've been in first case!"+ dw = displayWidth s++ellipsize, forceWidth :: Int -> String -> String+ellipsize = sizer False+forceWidth = sizer True charWidth :: Char -> Int charWidth = fromIntegral . wcwidth . toEnum . fromEnum
hmp3-ng.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 1f956746a3b58bb1485c816c5c816bd28deaaf3058aa792f61da8049145ad5b2+-- hash: 7e011cbec8ee4d43dd59e9069cbbf60c01ab0526f525032386a642899e629a25 name: hmp3-ng-version: 2.11.0+version: 2.12.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 file and directory names on the command line, and saved to the@@ -47,7 +47,7 @@ Paths_hmp3_ng hs-source-dirs: ./.- default-extensions: BangPatterns BlockArguments NondecreasingIndentation OverloadedStrings ScopedTypeVariables TypeApplications DerivingStrategies RecordWildCards LambdaCase+ default-extensions: BangPatterns BlockArguments NondecreasingIndentation OverloadedStrings ScopedTypeVariables TypeApplications DerivingStrategies RecordWildCards LambdaCase MultiWayIf ghc-options: -Wall -funbox-strict-fields -threaded -Wno-unused-do-bind extra-libraries: ncursesw@@ -61,7 +61,6 @@ , directory , filepath , hscurses- , monad-extras , mtl , pcre-light >=0.3 , process