UI.hs

-- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons
-- Copyright (c) 2019-2026 Galen Huntington
-- SPDX-License-Identifier: GPL-2.0-or-later
--
-- Derived from: riot/UI.hs Copyright (c) Tuomo Valkonen 2004.
-- Released under the same license.

-- | This module defines a user interface implemented using ncurses. 

module UI (
    runDraw,
    -- * Construction, destruction
    start, end, screenSize, refresh, refreshClock, resetui,
    -- * Input
    getKey,
    -- * Tool
    u,
  ) where

import Base
import Elements as El
import Style
import Playlist                 (File(dir, text), Dir(text))
import State
import Decoder
import Text                     (u, displayWidth, toMaxWidth, toWidth, spaces, showInt)
import UI.HSCurses.Curses qualified as Curses
import Keyboard                 (unkey)

import Data.Array               ((!), bounds, Array)
import Data.Array.Base          (unsafeAt)
import System.IO                (stderr, hFlush)
import System.Posix.Signals     (installHandler, Handler(..))

import Foreign.C.String
import Foreign.C.Types
import Foreign.C.Error (Errno(..), getErrno)

import Data.ByteString.Char8 qualified as P
import Data.ByteString.Unsafe qualified as P


newtype Draw = Draw (IO ())
    deriving newtype (Semigroup, Monoid)

drawLock :: MVar ()
drawLock = unsafePerformIO $ newMVar ()
{-# NOINLINE drawLock #-}

runDraw :: Draw -> IO ()
runDraw (Draw io) = withMVar drawLock $ const io

------------------------------------------------------------------------

-- | Initialize the UI
start :: IO UIStyle
start = do
    Curses.initCurses

    case Curses.cursesSigWinch of
        Just wch -> void $ installHandler wch (Catch resetui) Nothing
        _        -> pure () -- handled elsewhere

    colorify <- Curses.hasColors
    let sty = if colorify then defaultStyle else monoStyle

    initcolours sty
    Curses.keypad Curses.stdScr True    -- grab the keyboard
    runDraw nocursor

    pure sty

-- | Reset
resetui :: IO ()
resetui = runDraw (resizeui <> nocursor) *> refresh

-- | And force invisible
nocursor :: Draw
nocursor = Draw $ discardErrors $ void $ Curses.cursSet Curses.CursorInvisible

-- | Clean up and go home.
end :: IO ()
end = do
    takeMVar drawLock        -- we keep so no one tries to draw
    setXtermTitle ["xterm"]  -- XXX I don't see this title after exit?
    Curses.endWin

-- | Find the current screen height and width.
screenSize :: IO (Int, Int)
screenSize = Curses.scrSize

-- | Rewrite of Curses.getCh to avoid looping on terminal crash
-- | (also no unget support since I don't need it)
getCh :: IO Curses.Key
getCh = do
  threadWaitRead 0
  v <- Curses.getch
  case v of
    -1 -> do
        Errno e <- getErrno
        putStrLn $ "Error " ++ show e ++ "; terminal has gone away?  Hard-exiting now."
        exitFailure
    k -> pure $ Curses.decodeKey k

-- | Read a key. UIs need to define a method for getting events.
-- We only need to refresh if we don't have no SIGWINCH support.
getKey :: IO Char
getKey = do
    k <- getCh
    if k == Curses.KeyResize 
        then do
              when (isNothing Curses.cursesSigWinch) do
                  runDraw $ redraw <> resizeui
              getKey
        else pure $ unkey k

-- | Resize the window
-- From "Writing Programs with NCURSES", by Eric S. Raymond and Zeyd M. Ben-Halim
resizeui :: Draw
resizeui = Draw do
    Curses.endWin
    Curses.resetParams
    do
        -- not sure I need all these...
        Curses.nl True
        _ <- Curses.leaveOk True
        Curses.noDelay Curses.stdScr False
        Curses.cBreak True
        -- Curses.meta stdScr True -- not in module
        -- not sure about intrFlush, raw - set in hscurses
    Curses.refresh
    void Curses.scrSize

refresh :: IO ()
refresh = runDraw $ redraw <> Draw Curses.refresh

refreshClock :: IO ()
refreshClock = runDraw $ redrawJustClock <> Draw Curses.refresh

------------------------------------------------------------------------

data DrawData = DD { drawWidth :: !Int, drawState :: !HState }

------------------------------------------------------------------------

-- | Info about the current track
pPlaying :: DrawData -> Line
pPlaying dd = pure $ plainSeg $ "  " <> mconcat line where
    x = dd.drawWidth
    a = pId3 dd
    b = fromMaybe "" dd.drawState.info  -- mp3 info
    line | gap >= 0 = a : spaces gap : right
         | True     = toMaxWidth lim a : right
        where lim = x - 5 - (if showId3 then P.length b else -1)
              gap = lim - displayWidth a
              showId3 = x > 59
              right = if showId3 then [" ", b] else []

-- | Id3 info
pId3 :: DrawData -> ByteString
pId3 DD{drawState=st} = maybe (st.music ! st.current).text (.str) st.id3

------------------------------------------------------------------------

-- | Show progress bar.
progressBar :: DrawData -> Line
progressBar (DD w st) = [
    plainSeg "  ", Seg (Style fg fg) (spaces x), Seg sty (spaces (w'-x)) ]
  where
    w' = w - 4
    x = El.progress w' st.clock
    sty@(Style fg _) = st.uiStyle.progress

-- | Two lines showing clock.
clockLines :: DrawData -> [Line]
clockLines dd@(DD w st) = [progressBar dd, [plainSeg (El.pTimes w st.clock)]]

------------------------------------------------------------------------

-- | Play state
pState :: DrawData -> String
pState dd = case dd.drawState.status of
    Stopped -> "◼"
    Paused  -> "⏸"
    Playing -> "▶"

-- | Play mode
pMode :: DrawData -> String
pMode dd = take 4 $ map toLower $ show dd.drawState.mode

------------------------------------------------------------------------

-- | "x/n dirs y/m files" cursor position read-out.
playInfo :: DrawData -> ByteString
playInfo DD{drawState=st} = mconcat
    [ spaces (P.length numd - P.length curd)
    , curd, "/", numd, " dirs"
    , spaces (1 + P.length numf - P.length curf)
    , curf, "/", numf, " files"
    ]
  where
    curf  = showInt $ st.cursor + 1
    numf  = showInt $ st.size
    curd  = showInt $ (st.music ! st.cursor).dir + 1
    numd  = showInt $ length $ st.folders

-- | The top title bar: cursor position + play indicator + uptime + version.
playTitle :: DrawData -> Line
playTitle dd@DD{drawWidth=w, drawState=st} =
    [Seg st.uiStyle.titlebar $ El.layoutLCR w (left, centerS, right)]
  where
    left    = " " <> playInfo dd
    centerS = pState dd ++ ' ' : pMode dd  -- always 6 chars
    right   = st.uptime <> " " <> El.pVersion <> " "

-- | The scrolling playlist (visible tracks).
playList :: Int -> DrawData -> [Line]
playList buflen _ | buflen <= 0 = []  -- extra defense besides laziness
playList buflen DD{ drawWidth=w, drawState=st } =
    list ++ replicate (buflen - length list) []

  where
    -- number of screens down, and then offset
    (screens, select) = st.cursor `quotRem` buflen -- keep cursor in screen
    playing = st.current - screens * buflen -- invisible if out of bounds

    -- visible slice of the playlist
    visible = slice off (off + buflen - 1) st.music
        where off = screens * buflen

    visible' :: [(Maybe Int, ByteString)]
    visible' = loop (-1) visible where
        loop _ []     = []
        loop n (v:vs) =
            let r = if v.dir > n then Just v.dir else Nothing
            in (r, toMaxWidth (w - indent - 1) v.text) : loop v.dir vs

    list   = [ drawIt . color $ n | n <- zip visible' [0..] ]

    indent = round $ st.folderCol * fromIntegral (w - 1) :: Int

    (sty1, sty2, sty3) = (cs.selected, cs.cursors, cs.combined)
        where cs = st.uiStyle

    color :: ((Maybe Int, ByteString), Int)
                -> (Maybe Int, (Style, [ByteString]))
    color ((m, s), i) = (m,) case (i == select, i == playing) of
        (True, True) -> f sty3
        (True, _)    -> f sty2
        (_   , True) -> f sty1
        _            -> (defaultSty, [s])
      where
        f sty = (sty, [s, spaces (w - indent - 1 - displayWidth s)])

    drawIt :: (Maybe Int, (Style, [ByteString])) -> Line
    drawIt (Nothing, (sty, v)) =
        map (Seg sty) $ spaces (1 + indent) : v
    drawIt (Just i, (sty, v)) = Seg sty' d
        : Seg sty' (spaces (indent + 1 - displayWidth d))
        : map (Seg sty) v
      where
        sty' = if sty == sty2 || sty == sty3 then sty2 else sty1
        d = toMaxWidth (indent - 1) (st.folders ! i).text

------------------------------------------------------------------------
-- | Write out only the clock lines.
redrawJustClock :: Draw
redrawJustClock = Draw $ discardErrors do
    st <- getsHS id
    (h, w) <- screenSize
    drawFullLines (h-1) 1 $ clockLines $ DD w st

------------------------------------------------------------------------
-- | General modal renderer.
renderModal :: HState -> (Int, Int) -> ModalMaker -> IO ()
renderModal st (h, w) mkr = do
    let (mw, modal') = mkr w
        hoffset = max 0 $ (w - mw) `div` 2
        vislines = (h - 5) `min` length modal'
        voffset = ((h - vislines) `div` 2) `max` 4
    for_ (zip [voffset..] $ take vislines modal') \ (y, t) -> do
        Curses.wMove Curses.stdScr y hoffset
        drawSegment $ Seg st.uiStyle.modals (toWidth mw t)

-- | Choose modal to render based on state.
renderModals :: HState -> (Int, Int) -> IO ()
renderModals st sz =
    whenJust st.modal $ renderModal st sz . \case
        HelpModal h -> El.helpModal h
        HistModal h -> El.histModal h
        ExitModal   -> El.exitModal

------------------------------------------------------------------------
-- | Draw the screen
-- Errors can maybe be thrown if screen gets resized mid-render.
redraw :: Draw
redraw = Draw $ discardErrors do
    st <- getsHS id
    sz@(h, w) <- screenSize
    setXterm st
    drawFullLines (h-1) 0 $ let dd = DD w st in
        pPlaying dd : clockLines dd ++ playTitle dd : playList (h-5) dd
    renderModals st sz
    -- minibuffer
    Curses.wMove Curses.stdScr (h-1) 0
    drawLine st.minibuffer
    when st.miniFocused do -- a fake cursor
        drawSegment $ Seg st.uiStyle.blockcursor " "
    fillLine

-- | Render whole lines without going below limit.
drawFullLines :: Int -> Int -> [Line] -> IO ()
drawFullLines limit y ls =
    for_ (zip [y .. limit-1] ls) \ (y', t) -> do
        Curses.wMove Curses.stdScr y' 0
        drawLine t *> fillLine

------------------------------------------------------------------------
-- | Draw a coloured (or not) string to the screen
drawLine :: Line -> IO ()
drawLine = traverse_ drawSegment

-- | Write a single styled UTF-8 segment.  Safe because C only reads the bytes.
drawSegment :: Segment -> IO ()
drawSegment (Seg sty bs) = withStyle sty $ void $
    P.unsafeUseAsCStringLen bs \(cstr, len) ->
        waddnstr Curses.stdScr cstr (fromIntegral len)

------------------------------------------------------------------------

-- | Fill to end of line spaces
-- (Curses throws error if already at end.)
fillLine :: IO ()
fillLine = discardErrors Curses.clrToEol

-- | Take a slice of an array efficiently
slice :: Int -> Int -> Array Int e -> [e]
slice i j arr = 
    let (a, b) = bounds arr
    in [unsafeAt arr n | n <- [max a i .. min b j]]

------------------------------------------------------------------------

-- | magics for setting xterm titles using ansi escape sequences
setXtermTitle :: [ByteString] -> IO ()
setXtermTitle strs = do
    traverse_ (P.hPut stderr) (before : strs ++ [after])
    hFlush stderr 
  where
    before = "\ESC]0;"
    after  = "\007"

------------------------------------------------------------------------

-- set xterm title.  Don't need to do this on each refresh...
setXterm :: HState -> IO ()
setXterm st = setXtermTitle case st.status of
    Playing -> case st.id3 of
        Just id3 -> id3.artist :
                       if P.null id3.title then [] else [": ", id3.title]
        _        -> [(st.music ! st.current).text]
    Paused  -> ["paused"]
    Stopped -> ["stopped"]


foreign import ccall safe
    waddnstr :: Curses.Window -> CString -> CInt -> IO CInt