diff --git a/Base.hs b/Base.hs --- a/Base.hs +++ b/Base.hs @@ -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 [] diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -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 } diff --git a/Core.hs b/Core.hs --- a/Core.hs +++ b/Core.hs @@ -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) + diff --git a/FastIO.hs b/FastIO.hs --- a/FastIO.hs +++ b/FastIO.hs @@ -34,7 +34,6 @@ import System.Posix.Directory.ByteString import System.IO (hFlush) -import Control.Monad.Extra (sequenceWhile) ------------------------------------------------------------------------ diff --git a/Keymap.hs b/Keymap.hs --- a/Keymap.hs +++ b/Keymap.hs @@ -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", ['|']) ] diff --git a/Keymap.hs-boot b/Keymap.hs-boot --- a/Keymap.hs-boot +++ b/Keymap.hs-boot @@ -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 diff --git a/State.hs b/State.hs --- a/State.hs +++ b/State.hs @@ -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 diff --git a/Style.hs b/Style.hs --- a/Style.hs +++ b/Style.hs @@ -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 diff --git a/UI.hs b/UI.hs --- a/UI.hs +++ b/UI.hs @@ -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 diff --git a/hmp3-ng.cabal b/hmp3-ng.cabal --- a/hmp3-ng.cabal +++ b/hmp3-ng.cabal @@ -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