{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-}

module Hydra.TUI.Drawing.Utils where

import Hydra.Prelude

import Brick (Padding (..), ViewportType (Vertical), Widget, clickable, padLeft, str, txt, vBox, viewport, withAttr, (<+>))
import Cardano.Api.UTxO qualified as UTxO
import Data.Map qualified as Map
import Data.Text qualified as T
import Data.Time (defaultTimeLocale, formatTime, utctDayTime)
import Data.Time.Format (FormatTime)
import Hydra.API.ServerOutput (FanoutProgressMode (..))
import Hydra.Cardano.Api hiding (Active)
import Hydra.TUI.Style (infoA, own, sectionHeaderA)
import Hydra.Tx (HeadId, IsTx (..))

-- | Render a 'HeadId' as its hex-encoded bytes (matches the Main tab display).
prettyHeadId :: HeadId -> Text
prettyHeadId :: HeadId -> Text
prettyHeadId = HeadId -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText

-- | Render a 'TxId' as its hex-encoded bytes (no quotes, no wrapper type).
prettyTxId :: TxId -> Text
prettyTxId :: TxId -> Text
prettyTxId = TxId -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText

drawHex :: SerialiseAsRawBytes a => a -> Widget n
drawHex :: forall a n. SerialiseAsRawBytes a => a -> Widget n
drawHex = Text -> Widget n
forall n. Text -> Widget n
txt (Text -> Widget n) -> (a -> Text) -> a -> Widget n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"⚬ " <>) (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText

drawShow :: forall a n. Show a => a -> Widget n
drawShow :: forall a n. Show a => a -> Widget n
drawShow = Text -> Widget n
forall n. Text -> Widget n
txt (Text -> Widget n) -> (a -> Text) -> a -> Widget n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall b a. (Show a, IsString b) => a -> b
show

-- | Render a full address as text.
drawAddress :: AddressInEra -> Widget n
drawAddress :: forall n. AddressInEra -> Widget n
drawAddress AddressInEra
addr = Text -> Widget n
forall n. Text -> Widget n
txt (AddressInEra -> Text
forall addr. SerialiseAddress addr => addr -> Text
serialiseAddress AddressInEra
addr)

-- | Highlight the given address if it matches the own address.
highlightOwnAddress :: AddressInEra -> AddressInEra -> Widget n
highlightOwnAddress :: forall n. AddressInEra -> AddressInEra -> Widget n
highlightOwnAddress AddressInEra
ownAddress AddressInEra
a =
  AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr (if AddressInEra
a AddressInEra -> AddressInEra -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra
ownAddress then AttrName
own else AttrName
forall a. Monoid a => a
mempty) (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ AddressInEra -> Widget n
forall n. AddressInEra -> Widget n
drawAddress AddressInEra
a

-- | Render a UTxO map grouped by address, with ADA amounts and global 1-based
-- numbering across all entries (so users can confirm scrollable views are scrolling).
drawUTxO :: (AddressInEra -> Widget n) -> UTxO -> Widget n
drawUTxO :: forall n. (AddressInEra -> Widget n) -> UTxO -> Widget n
drawUTxO AddressInEra -> Widget n
f UTxO
utxo =
  let byAddress :: Map AddressInEra [(TxIn, TxOut CtxUTxO)]
byAddress =
        (TxIn
 -> TxOut CtxUTxO
 -> Map AddressInEra [(TxIn, TxOut CtxUTxO)]
 -> Map AddressInEra [(TxIn, TxOut CtxUTxO)])
-> Map AddressInEra [(TxIn, TxOut CtxUTxO)]
-> Map TxIn (TxOut CtxUTxO)
-> Map AddressInEra [(TxIn, TxOut CtxUTxO)]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
          (\TxIn
k v :: TxOut CtxUTxO
v@TxOut{txOutAddress :: forall ctx. TxOut ctx -> AddressInEra
txOutAddress = AddressInEra
addr} -> ([(TxIn, TxOut CtxUTxO)]
 -> [(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)])
-> Map AddressInEra [(TxIn, TxOut CtxUTxO)]
-> Map AddressInEra [(TxIn, TxOut CtxUTxO)]
-> Map AddressInEra [(TxIn, TxOut CtxUTxO)]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [(TxIn, TxOut CtxUTxO)]
-> [(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)]
forall a. [a] -> [a] -> [a]
(++) (AddressInEra
-> [(TxIn, TxOut CtxUTxO)]
-> Map AddressInEra [(TxIn, TxOut CtxUTxO)]
forall k a. k -> a -> Map k a
Map.singleton AddressInEra
addr [(TxIn
k, TxOut CtxUTxO
v)]))
          Map AddressInEra [(TxIn, TxOut CtxUTxO)]
forall a. Monoid a => a
mempty
          (Map TxIn (TxOut CtxUTxO)
 -> Map AddressInEra [(TxIn, TxOut CtxUTxO)])
-> Map TxIn (TxOut CtxUTxO)
-> Map AddressInEra [(TxIn, TxOut CtxUTxO)]
forall a b. (a -> b) -> a -> b
$ UTxO -> Map TxIn (TxOut CtxUTxO)
forall era. UTxO era -> Map TxIn (TxOut CtxUTxO era)
UTxO.toMap UTxO
utxo
      indexedGroups :: [(AddressInEra, [(Int, (TxIn, TxOut CtxUTxO))])]
indexedGroups =
        (Int, [(AddressInEra, [(Int, (TxIn, TxOut CtxUTxO))])])
-> [(AddressInEra, [(Int, (TxIn, TxOut CtxUTxO))])]
forall a b. (a, b) -> b
snd ((Int, [(AddressInEra, [(Int, (TxIn, TxOut CtxUTxO))])])
 -> [(AddressInEra, [(Int, (TxIn, TxOut CtxUTxO))])])
-> (Int, [(AddressInEra, [(Int, (TxIn, TxOut CtxUTxO))])])
-> [(AddressInEra, [(Int, (TxIn, TxOut CtxUTxO))])]
forall a b. (a -> b) -> a -> b
$
          (Int
 -> (AddressInEra, [(TxIn, TxOut CtxUTxO)])
 -> (Int, (AddressInEra, [(Int, (TxIn, TxOut CtxUTxO))])))
-> Int
-> [(AddressInEra, [(TxIn, TxOut CtxUTxO)])]
-> (Int, [(AddressInEra, [(Int, (TxIn, TxOut CtxUTxO))])])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL
            ( \Int
nextIdx (AddressInEra
addr, [(TxIn, TxOut CtxUTxO)]
entries) ->
                let nEntries :: Int
nEntries = [(TxIn, TxOut CtxUTxO)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxIn, TxOut CtxUTxO)]
entries
                 in (Int
nextIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nEntries, (AddressInEra
addr, [Int] -> [(TxIn, TxOut CtxUTxO)] -> [(Int, (TxIn, TxOut CtxUTxO))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
nextIdx ..] [(TxIn, TxOut CtxUTxO)]
entries))
            )
            (Int
1 :: Int)
            (Map AddressInEra [(TxIn, TxOut CtxUTxO)]
-> [(AddressInEra, [(TxIn, TxOut CtxUTxO)])]
forall k a. Map k a -> [(k, a)]
Map.toList Map AddressInEra [(TxIn, TxOut CtxUTxO)]
byAddress)
   in [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
vBox
        [ [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
vBox
          [ AddressInEra -> Widget n
f AddressInEra
addr
          , Padding -> Widget n -> Widget n
forall n. Padding -> Widget n -> Widget n
padLeft (Int -> Padding
Pad Int
2) (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
vBox ((Int -> (TxIn, TxOut CtxUTxO) -> Widget n)
-> (Int, (TxIn, TxOut CtxUTxO)) -> Widget n
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> (TxIn, TxOut CtxUTxO) -> Widget n
forall n. Int -> (TxIn, TxOut CtxUTxO) -> Widget n
drawUTxOEntryAda ((Int, (TxIn, TxOut CtxUTxO)) -> Widget n)
-> [(Int, (TxIn, TxOut CtxUTxO))] -> [Widget n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, (TxIn, TxOut CtxUTxO))]
u)
          ]
        | (AddressInEra
addr, [(Int, (TxIn, TxOut CtxUTxO))]
u) <- [(AddressInEra, [(Int, (TxIn, TxOut CtxUTxO))])]
indexedGroups
        ]

-- | Render a single UTxO entry: index, last part of the TxIn, and ADA value.
-- The TxIn is shortened to the last 10 characters of the hash plus its
-- '#index' suffix, derived structurally so it stays correct if the rendering
-- of 'TxIn' ever changes width.
drawUTxOEntryAda :: Int -> (TxIn, TxOut CtxUTxO) -> Widget n
drawUTxOEntryAda :: forall n. Int -> (TxIn, TxOut CtxUTxO) -> Widget n
drawUTxOEntryAda Int
idx (TxIn
txin, TxOut AddressInEra
_ Value
val TxOutDatum CtxUTxO
_ ReferenceScript
_) =
  let (Text
hashHex, Text
idxPart) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"#" (TxIn -> Text
renderTxIn TxIn
txin)
      shortened :: Text
shortened = Int -> Text -> Text
T.takeEnd Int
10 Text
hashHex Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
idxPart
   in Text -> Widget n
forall n. Text -> Widget n
txt (Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
shortened Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"  ") Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
infoA (Text -> Widget n
forall n. Text -> Widget n
txt (Value -> Text
renderAda Value
val))

-- | Wrap a widget in a clickable, vertically scrollable viewport using a single name
-- for both. The shared name lets the mouse-wheel handler (matching MouseDown on any
-- clickable) target the corresponding viewport, and lets keyboard handlers scroll it
-- by name too.
scrollableViewport :: (Ord n, Show n) => n -> Widget n -> Widget n
scrollableViewport :: forall n. (Ord n, Show n) => n -> Widget n -> Widget n
scrollableViewport n
name = n -> Widget n -> Widget n
forall n. Ord n => n -> Widget n -> Widget n
clickable n
name (Widget n -> Widget n)
-> (Widget n -> Widget n) -> Widget n -> Widget n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> ViewportType -> Widget n -> Widget n
forall n.
(Ord n, Show n) =>
n -> ViewportType -> Widget n -> Widget n
viewport n
name ViewportType
Vertical

-- | Render a lovelace value as ADA with the ₳ symbol.
renderAda :: Value -> Text
renderAda :: Value -> Text
renderAda Value
v =
  let Coin Integer
l = Value -> Coin
selectLovelace Value
v
      (Integer
ada, Integer
frac) = Integer -> Integer
forall a. Num a => a -> a
abs Integer
l Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
1_000_000
      fracStr :: [Char]
fracStr = Integer -> [Char]
forall b a. (Show a, IsString b) => a -> b
show Integer
frac
      padded :: [Char]
padded = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
fracStr) Char
'0' [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
fracStr
      sign :: Text
sign = if Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Text
"-" else Text
""
   in Text
sign Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"₳ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show Integer
ada Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. ToText a => a -> Text
toText [Char]
padded

-- | Format a time duration as "Xd Xh Xm Xs".
renderTime :: (Ord t, Num t, FormatTime t) => t -> String
renderTime :: forall t. (Ord t, Num t, FormatTime t) => t -> [Char]
renderTime t
r
  | t
r t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
0 = [Char]
"-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> t -> [Char]
forall t. (Ord t, Num t, FormatTime t) => t -> [Char]
renderTime (t -> t
forall a. Num a => a -> a
negate t
r)
  | Bool
otherwise = TimeLocale -> [Char] -> t -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%dd %Hh %Mm %Ss" t
r

-- | Animated spinner character cycling with wall-clock time.
spinnerFrame :: UTCTime -> Text
spinnerFrame :: UTCTime -> Text
spinnerFrame UTCTime
now =
  let frames :: [Text]
frames = [Text
"⠋", Text
"⠙", Text
"⠹", Text
"⠸", Text
"⠼", Text
"⠴", Text
"⠦", Text
"⠧", Text
"⠇", Text
"⠏"] :: [Text]
      s :: Int
s = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> DiffTime
utctDayTime UTCTime
now) :: Double) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Int
10 :: Int)
   in case Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
s [Text]
frames of
        (Text
f : [Text]
_) -> Text
f
        [] -> Text
"⠋"

-- | Remaining contestation time, or a "ready to fan out" notice.
-- Used by both the Main tab (head state panel) and the Funds tab (closed state).
drawRemainingContestationPeriod :: UTCTime -> UTCTime -> Widget n
drawRemainingContestationPeriod :: forall n. UTCTime -> UTCTime -> Widget n
drawRemainingContestationPeriod UTCTime
deadline UTCTime
now =
  let remaining :: NominalDiffTime
remaining = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
deadline UTCTime
now
   in if NominalDiffTime
remaining NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0
        then AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
sectionHeaderA (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Text -> Widget n
forall n. Text -> Widget n
txt Text
"Remaining time to contest: " Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> [Char] -> Widget n
forall n. [Char] -> Widget n
str (NominalDiffTime -> [Char]
forall t. (Ord t, Num t, FormatTime t) => t -> [Char]
renderTime NominalDiffTime
remaining)
        else Widget n
forall n. Widget n
drawFanoutPossibleMessage

-- | Status message shown when the contestation period has passed and a
-- fanout transaction can be submitted. Shared between the Main and Funds
-- tabs so the wording matches.
drawFanoutPossibleMessage :: Widget n
drawFanoutPossibleMessage :: forall n. Widget n
drawFanoutPossibleMessage =
  AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
sectionHeaderA (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Text -> Widget n
forall n. Text -> Widget n
txt Text
"Contestation period passed — ready to fan out."

-- | Status message shown while a fanout is in progress, reporting how many UTxO
-- are still to be fanned out. The wording follows the node-reported
-- 'FanoutProgressMode': while auto-draining we just report progress; when the
-- node awaits the next selection we prompt for [P]. Shared between the Main and
-- Funds tabs so the wording and count match.
drawFanningOutMessage :: FanoutProgressMode -> UTxO -> Widget n
drawFanningOutMessage :: forall n. FanoutProgressMode -> UTxO -> Widget n
drawFanningOutMessage FanoutProgressMode
mode UTxO
remaining =
  AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
infoA (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Text -> Widget n
forall n. Text -> Widget n
txt Text
message
 where
  count :: Text
count = Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
remaining)
  message :: Text
message = case FanoutProgressMode
mode of
    FanoutProgressMode
AutoFanningOut ->
      Text
"Fanning out — " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
count Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" UTxO remaining…"
    FanoutProgressMode
AwaitingFanoutSelection ->
      Text
"Partial fanout paused — " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
count Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" UTxO remaining (press [P] to fan out more)"

-- | Status message shown when the head has been finalized, including the
-- total ADA value of the distributed UTxO. Shared between the Main and
-- Funds tabs so the wording matches.
drawHeadFinalizedMessage :: UTxO -> Widget n
drawHeadFinalizedMessage :: forall n. UTxO -> Widget n
drawHeadFinalizedMessage UTxO
utxo =
  [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
vBox
    [ AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
sectionHeaderA (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Text -> Widget n
forall n. Text -> Widget n
txt Text
"Head finalized."
    , Text -> Widget n
forall n. Text -> Widget n
txt (Text
"Distributed UTxO — total: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderAda (forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance @Tx UTxO
UTxOType Tx
utxo))
    ]