-- | Monadic operations on slideshows and related data.
module Game.LambdaHack.Client.UI.SlideshowM
  ( overlayToSlideshow, reportToSlideshow, reportToSlideshowKeep
  , displaySpaceEsc, displayMore, displayMoreKeep, displayYesNo, getConfirms
  , displayChoiceScreen
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Data.Either
import qualified Data.Map.Strict as M

import           Game.LambdaHack.Client.UI.Content.Screen
import           Game.LambdaHack.Client.UI.ContentClientUI
import           Game.LambdaHack.Client.UI.FrameM
import           Game.LambdaHack.Client.UI.ItemSlot
import qualified Game.LambdaHack.Client.UI.Key as K
import           Game.LambdaHack.Client.UI.MonadClientUI
import           Game.LambdaHack.Client.UI.MsgM
import           Game.LambdaHack.Client.UI.Overlay
import           Game.LambdaHack.Client.UI.SessionUI
import           Game.LambdaHack.Client.UI.Slideshow
import           Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Definition.Color as Color
import           Game.LambdaHack.Definition.Defs

-- | Add current report to the overlay, split the result and produce,
-- possibly, many slides.
overlayToSlideshow :: MonadClientUI m => Y -> [K.KM] -> OKX -> m Slideshow
overlayToSlideshow :: Y -> [KM] -> OKX -> m Slideshow
overlayToSlideshow y :: Y
y keys :: [KM]
keys okx :: OKX
okx = do
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Y
rwidth :: ScreenContent -> Y
rwidth :: Y
rwidth}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  Report
report <- m Report
forall (m :: * -> *). MonadClientUI m => m Report
getReportUI
  m ()
forall (m :: * -> *). MonadClientUI m => m ()
recordHistory  -- report will be shown soon, remove it to history
  Slideshow -> m Slideshow
forall (m :: * -> *) a. Monad m => a -> m a
return (Slideshow -> m Slideshow) -> Slideshow -> m Slideshow
forall a b. (a -> b) -> a -> b
$! Y -> Y -> Report -> [KM] -> OKX -> Slideshow
splitOverlay Y
rwidth Y
y Report
report [KM]
keys OKX
okx

-- | Split current report into a slideshow.
reportToSlideshow :: MonadClientUI m => [K.KM] -> m Slideshow
reportToSlideshow :: [KM] -> m Slideshow
reportToSlideshow keys :: [KM]
keys = do
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Y
rheight :: ScreenContent -> Y
rheight :: Y
rheight}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  Y -> [KM] -> OKX -> m Slideshow
forall (m :: * -> *).
MonadClientUI m =>
Y -> [KM] -> OKX -> m Slideshow
overlayToSlideshow (Y
rheight Y -> Y -> Y
forall a. Num a => a -> a -> a
- 2) [KM]
keys ([], [])

-- | Split current report into a slideshow. Keep report unchanged.
reportToSlideshowKeep :: MonadClientUI m => [K.KM] -> m Slideshow
reportToSlideshowKeep :: [KM] -> m Slideshow
reportToSlideshowKeep keys :: [KM]
keys = do
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Y
rwidth :: Y
rwidth :: ScreenContent -> Y
rwidth, Y
rheight :: Y
rheight :: ScreenContent -> Y
rheight}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  Report
report <- m Report
forall (m :: * -> *). MonadClientUI m => m Report
getReportUI
  -- Don't do @recordHistory@; the message is important, but related
  -- to the messages that come after, so should be shown together.
  Slideshow -> m Slideshow
forall (m :: * -> *) a. Monad m => a -> m a
return (Slideshow -> m Slideshow) -> Slideshow -> m Slideshow
forall a b. (a -> b) -> a -> b
$! Y -> Y -> Report -> [KM] -> OKX -> Slideshow
splitOverlay Y
rwidth (Y
rheight Y -> Y -> Y
forall a. Num a => a -> a -> a
- 2) Report
report [KM]
keys ([], [])

-- | Display a message. Return value indicates if the player wants to continue.
-- Feature: if many pages, only the last SPACE exits (but first ESC).
displaySpaceEsc :: MonadClientUI m => ColorMode -> Text -> m Bool
displaySpaceEsc :: ColorMode -> Text -> m Bool
displaySpaceEsc dm :: ColorMode
dm prompt :: Text
prompt = do
  Text -> m ()
forall (m :: * -> *). MonadClientUI m => Text -> m ()
promptAdd0 Text
prompt
  -- Two frames drawn total (unless @prompt@ very long).
  Slideshow
slides <- [KM] -> m Slideshow
forall (m :: * -> *). MonadClientUI m => [KM] -> m Slideshow
reportToSlideshow [KM
K.spaceKM, KM
K.escKM]
  KM
km <- ColorMode -> [KM] -> Slideshow -> m KM
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> [KM] -> Slideshow -> m KM
getConfirms ColorMode
dm [KM
K.spaceKM, KM
K.escKM] Slideshow
slides
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$! KM
km KM -> KM -> Bool
forall a. Eq a => a -> a -> Bool
== KM
K.spaceKM

-- | Display a message. Ignore keypresses.
-- Feature: if many pages, only the last SPACE exits (but first ESC).
displayMore :: MonadClientUI m => ColorMode -> Text -> m ()
displayMore :: ColorMode -> Text -> m ()
displayMore dm :: ColorMode
dm prompt :: Text
prompt = do
  Text -> m ()
forall (m :: * -> *). MonadClientUI m => Text -> m ()
promptAdd0 Text
prompt
  Slideshow
slides <- [KM] -> m Slideshow
forall (m :: * -> *). MonadClientUI m => [KM] -> m Slideshow
reportToSlideshow [KM
K.spaceKM]
  m KM -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m KM -> m ()) -> m KM -> m ()
forall a b. (a -> b) -> a -> b
$ ColorMode -> [KM] -> Slideshow -> m KM
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> [KM] -> Slideshow -> m KM
getConfirms ColorMode
dm [KM
K.spaceKM, KM
K.escKM] Slideshow
slides

displayMoreKeep :: MonadClientUI m => ColorMode -> Text -> m ()
displayMoreKeep :: ColorMode -> Text -> m ()
displayMoreKeep dm :: ColorMode
dm prompt :: Text
prompt = do
  Text -> m ()
forall (m :: * -> *). MonadClientUI m => Text -> m ()
promptAdd0 Text
prompt
  Slideshow
slides <- [KM] -> m Slideshow
forall (m :: * -> *). MonadClientUI m => [KM] -> m Slideshow
reportToSlideshowKeep [KM
K.spaceKM]
  m KM -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m KM -> m ()) -> m KM -> m ()
forall a b. (a -> b) -> a -> b
$ ColorMode -> [KM] -> Slideshow -> m KM
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> [KM] -> Slideshow -> m KM
getConfirms ColorMode
dm [KM
K.spaceKM, KM
K.escKM] Slideshow
slides

-- | Print a yes/no question and return the player's answer. Use black
-- and white colours to turn player's attention to the choice.
displayYesNo :: MonadClientUI m => ColorMode -> Text -> m Bool
displayYesNo :: ColorMode -> Text -> m Bool
displayYesNo dm :: ColorMode
dm prompt :: Text
prompt = do
  Text -> m ()
forall (m :: * -> *). MonadClientUI m => Text -> m ()
promptAdd0 Text
prompt
  let yn :: [KM]
yn = (Char -> KM) -> [Char] -> [KM]
forall a b. (a -> b) -> [a] -> [b]
map Char -> KM
K.mkChar ['y', 'n']
  Slideshow
slides <- [KM] -> m Slideshow
forall (m :: * -> *). MonadClientUI m => [KM] -> m Slideshow
reportToSlideshow [KM]
yn
  KM
km <- ColorMode -> [KM] -> Slideshow -> m KM
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> [KM] -> Slideshow -> m KM
getConfirms ColorMode
dm (KM
K.escKM KM -> [KM] -> [KM]
forall a. a -> [a] -> [a]
: [KM]
yn) Slideshow
slides
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$! KM
km KM -> KM -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> KM
K.mkChar 'y'

getConfirms :: MonadClientUI m
            => ColorMode -> [K.KM] -> Slideshow -> m K.KM
getConfirms :: ColorMode -> [KM] -> Slideshow -> m KM
getConfirms dm :: ColorMode
dm extraKeys :: [KM]
extraKeys slides :: Slideshow
slides = do
  Either KM SlotChar
ekm <- [Char]
-> ColorMode -> Bool -> Slideshow -> [KM] -> m (Either KM SlotChar)
forall (m :: * -> *).
MonadClientUI m =>
[Char]
-> ColorMode -> Bool -> Slideshow -> [KM] -> m (Either KM SlotChar)
displayChoiceScreen "" ColorMode
dm Bool
False Slideshow
slides [KM]
extraKeys
  KM -> m KM
forall (m :: * -> *) a. Monad m => a -> m a
return (KM -> m KM) -> KM -> m KM
forall a b. (a -> b) -> a -> b
$! (KM -> KM) -> (SlotChar -> KM) -> Either KM SlotChar -> KM
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either KM -> KM
forall a. a -> a
id ([Char] -> SlotChar -> KM
forall a. HasCallStack => [Char] -> a
error ([Char] -> SlotChar -> KM) -> [Char] -> SlotChar -> KM
forall a b. (a -> b) -> a -> b
$ "" [Char] -> Either KM SlotChar -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` Either KM SlotChar
ekm) Either KM SlotChar
ekm

-- | Display a, potentially, multi-screen menu and return the chosen
-- key or item slot label (and the index in the whole menu so that the cursor
-- can again be placed at that spot next time menu is displayed).
--
-- This function is the only source of menus and so, effectively, UI modes.
displayChoiceScreen :: forall m . MonadClientUI m
                    => String -> ColorMode -> Bool -> Slideshow -> [K.KM]
                    -> m (Either K.KM SlotChar)
displayChoiceScreen :: [Char]
-> ColorMode -> Bool -> Slideshow -> [KM] -> m (Either KM SlotChar)
displayChoiceScreen menuName :: [Char]
menuName dm :: ColorMode
dm sfBlank :: Bool
sfBlank frsX :: Slideshow
frsX extraKeys :: [KM]
extraKeys = do
  let frs :: [OKX]
frs = Slideshow -> [OKX]
slideshow Slideshow
frsX
      keys :: [KM]
keys = (OKX -> [KM]) -> [OKX] -> [KM]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Either [KM] SlotChar, (Y, Y, Y)) -> [KM])
-> [(Either [KM] SlotChar, (Y, Y, Y))] -> [KM]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([KM] -> [KM])
-> (SlotChar -> [KM]) -> Either [KM] SlotChar -> [KM]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [KM] -> [KM]
forall a. a -> a
id ([KM] -> SlotChar -> [KM]
forall a b. a -> b -> a
const []) (Either [KM] SlotChar -> [KM])
-> ((Either [KM] SlotChar, (Y, Y, Y)) -> Either [KM] SlotChar)
-> (Either [KM] SlotChar, (Y, Y, Y))
-> [KM]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either [KM] SlotChar, (Y, Y, Y)) -> Either [KM] SlotChar
forall a b. (a, b) -> a
fst) ([(Either [KM] SlotChar, (Y, Y, Y))] -> [KM])
-> (OKX -> [(Either [KM] SlotChar, (Y, Y, Y))]) -> OKX -> [KM]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OKX -> [(Either [KM] SlotChar, (Y, Y, Y))]
forall a b. (a, b) -> b
snd) [OKX]
frs
             [KM] -> [KM] -> [KM]
forall a. [a] -> [a] -> [a]
++ [KM]
extraKeys
      !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (KM
K.escKM KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
extraKeys) ()
      navigationKeys :: [KM]
navigationKeys = [ KM
K.leftButtonReleaseKM, KM
K.rightButtonReleaseKM
                       , KM
K.returnKM, KM
K.spaceKM
                       , KM
K.upKM, KM
K.leftKM, KM
K.downKM, KM
K.rightKM
                       , KM
K.pgupKM, KM
K.pgdnKM, KM
K.wheelNorthKM, KM
K.wheelSouthKM
                       , KM
K.homeKM, KM
K.endKM, KM
K.controlP ]
      legalKeys :: [KM]
legalKeys = [KM]
keys [KM] -> [KM] -> [KM]
forall a. [a] -> [a] -> [a]
++ [KM]
navigationKeys
      -- The arguments go from first menu line and menu page to the last,
      -- in order. Their indexing is from 0. We select the nearest item
      -- with the index equal or less to the pointer.
      findKYX :: Int -> [OKX] -> Maybe (OKX, KYX, Int)
      findKYX :: Y -> [OKX] -> Maybe (OKX, (Either [KM] SlotChar, (Y, Y, Y)), Y)
findKYX _ [] = Maybe (OKX, (Either [KM] SlotChar, (Y, Y, Y)), Y)
forall a. Maybe a
Nothing
      findKYX pointer :: Y
pointer (okx :: OKX
okx@(_, kyxs :: [(Either [KM] SlotChar, (Y, Y, Y))]
kyxs) : frs2 :: [OKX]
frs2) =
        case Y
-> [(Either [KM] SlotChar, (Y, Y, Y))]
-> [(Either [KM] SlotChar, (Y, Y, Y))]
forall a. Y -> [a] -> [a]
drop Y
pointer [(Either [KM] SlotChar, (Y, Y, Y))]
kyxs of
          [] ->  -- not enough menu items on this page
            case Y -> [OKX] -> Maybe (OKX, (Either [KM] SlotChar, (Y, Y, Y)), Y)
findKYX (Y
pointer Y -> Y -> Y
forall a. Num a => a -> a -> a
- [(Either [KM] SlotChar, (Y, Y, Y))] -> Y
forall a. [a] -> Y
length [(Either [KM] SlotChar, (Y, Y, Y))]
kyxs) [OKX]
frs2 of
              Nothing ->  -- no more menu items in later pages
                case [(Either [KM] SlotChar, (Y, Y, Y))]
-> [(Either [KM] SlotChar, (Y, Y, Y))]
forall a. [a] -> [a]
reverse [(Either [KM] SlotChar, (Y, Y, Y))]
kyxs of
                  [] -> Maybe (OKX, (Either [KM] SlotChar, (Y, Y, Y)), Y)
forall a. Maybe a
Nothing
                  kyx :: (Either [KM] SlotChar, (Y, Y, Y))
kyx : _ -> (OKX, (Either [KM] SlotChar, (Y, Y, Y)), Y)
-> Maybe (OKX, (Either [KM] SlotChar, (Y, Y, Y)), Y)
forall a. a -> Maybe a
Just (OKX
okx, (Either [KM] SlotChar, (Y, Y, Y))
kyx, [(Either [KM] SlotChar, (Y, Y, Y))] -> Y
forall a. [a] -> Y
length [(Either [KM] SlotChar, (Y, Y, Y))]
kyxs Y -> Y -> Y
forall a. Num a => a -> a -> a
- 1)
              res :: Maybe (OKX, (Either [KM] SlotChar, (Y, Y, Y)), Y)
res -> Maybe (OKX, (Either [KM] SlotChar, (Y, Y, Y)), Y)
res
          kyx :: (Either [KM] SlotChar, (Y, Y, Y))
kyx : _ -> (OKX, (Either [KM] SlotChar, (Y, Y, Y)), Y)
-> Maybe (OKX, (Either [KM] SlotChar, (Y, Y, Y)), Y)
forall a. a -> Maybe a
Just (OKX
okx, (Either [KM] SlotChar, (Y, Y, Y))
kyx, Y
pointer)
      maxIx :: Y
maxIx = [(Either [KM] SlotChar, (Y, Y, Y))] -> Y
forall a. [a] -> Y
length ((OKX -> [(Either [KM] SlotChar, (Y, Y, Y))])
-> [OKX] -> [(Either [KM] SlotChar, (Y, Y, Y))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OKX -> [(Either [KM] SlotChar, (Y, Y, Y))]
forall a b. (a, b) -> b
snd [OKX]
frs) Y -> Y -> Y
forall a. Num a => a -> a -> a
- 1
      allOKX :: [(Either [KM] SlotChar, (Y, Y, Y))]
allOKX = (OKX -> [(Either [KM] SlotChar, (Y, Y, Y))])
-> [OKX] -> [(Either [KM] SlotChar, (Y, Y, Y))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OKX -> [(Either [KM] SlotChar, (Y, Y, Y))]
forall a b. (a, b) -> b
snd [OKX]
frs
      initIx :: Y
initIx = case ((Either [KM] SlotChar, (Y, Y, Y)) -> Bool)
-> [(Either [KM] SlotChar, (Y, Y, Y))] -> Maybe Y
forall a. (a -> Bool) -> [a] -> Maybe Y
findIndex (Either [KM] SlotChar -> Bool
forall a b. Either a b -> Bool
isRight (Either [KM] SlotChar -> Bool)
-> ((Either [KM] SlotChar, (Y, Y, Y)) -> Either [KM] SlotChar)
-> (Either [KM] SlotChar, (Y, Y, Y))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either [KM] SlotChar, (Y, Y, Y)) -> Either [KM] SlotChar
forall a b. (a, b) -> a
fst) [(Either [KM] SlotChar, (Y, Y, Y))]
allOKX of
        Just p :: Y
p -> Y
p
        _ -> 0  -- can't be @length allOKX@ or a multi-page item menu
                -- mangles saved index of other item munus
      clearIx :: Y
clearIx = if Y
initIx Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
> Y
maxIx then 0 else Y
initIx
      page :: Int -> m (Either K.KM SlotChar, Int)
      page :: Y -> m (Either KM SlotChar, Y)
page pointer :: Y
pointer = Bool -> m (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y)
forall a. HasCallStack => Bool -> a -> a
assert (Y
pointer Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
>= 0) (m (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y))
-> m (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y)
forall a b. (a -> b) -> a -> b
$ case Y -> [OKX] -> Maybe (OKX, (Either [KM] SlotChar, (Y, Y, Y)), Y)
findKYX Y
pointer [OKX]
frs of
        Nothing -> [Char] -> m (Either KM SlotChar, Y)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Either KM SlotChar, Y))
-> [Char] -> m (Either KM SlotChar, Y)
forall a b. (a -> b) -> a -> b
$ "no menu keys" [Char] -> [OKX] -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` [OKX]
frs
        Just ((ov :: Overlay
ov, kyxs :: [(Either [KM] SlotChar, (Y, Y, Y))]
kyxs), (ekm :: Either [KM] SlotChar
ekm, (y :: Y
y, x1 :: Y
x1, x2 :: Y
x2)), ixOnPage :: Y
ixOnPage) -> do
          let highableAttrs :: [Attr]
highableAttrs =
                [Attr
Color.defAttr, Attr
Color.defAttr {fg :: Color
Color.fg = Color
Color.BrBlack}]
              highAttr :: AttrChar -> AttrChar
highAttr x :: AttrChar
x | AttrChar -> Attr
Color.acAttr AttrChar
x Attr -> [Attr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Attr]
highableAttrs = AttrChar
x
              highAttr x :: AttrChar
x = AttrChar
x {acAttr :: Attr
Color.acAttr =
                                (AttrChar -> Attr
Color.acAttr AttrChar
x) {fg :: Color
Color.fg = Color
Color.BrWhite}}
              cursorAttr :: AttrChar -> AttrChar
cursorAttr x :: AttrChar
x = AttrChar
x {acAttr :: Attr
Color.acAttr =
                                  (AttrChar -> Attr
Color.acAttr AttrChar
x)
                                    {bg :: Highlight
Color.bg = Highlight
Color.HighlightNoneCursor}}
              drawHighlight :: [AttrCharW32] -> [AttrCharW32]
drawHighlight xs :: [AttrCharW32]
xs =
                let (xs1 :: [AttrCharW32]
xs1, xsRest :: [AttrCharW32]
xsRest) = Y -> [AttrCharW32] -> ([AttrCharW32], [AttrCharW32])
forall a. Y -> [a] -> ([a], [a])
splitAt Y
x1 [AttrCharW32]
xs
                    (xs2 :: [AttrCharW32]
xs2, xs3 :: [AttrCharW32]
xs3) = Y -> [AttrCharW32] -> ([AttrCharW32], [AttrCharW32])
forall a. Y -> [a] -> ([a], [a])
splitAt (Y
x2 Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
x1) [AttrCharW32]
xsRest
                    highW32 :: AttrCharW32 -> AttrCharW32
highW32 = AttrChar -> AttrCharW32
Color.attrCharToW32
                              (AttrChar -> AttrCharW32)
-> (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrCharW32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrChar -> AttrChar
highAttr
                              (AttrChar -> AttrChar)
-> (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrChar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrCharW32 -> AttrChar
Color.attrCharFromW32
                    cursorW32 :: AttrCharW32 -> AttrCharW32
cursorW32 = AttrChar -> AttrCharW32
Color.attrCharToW32
                                (AttrChar -> AttrCharW32)
-> (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrCharW32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrChar -> AttrChar
cursorAttr
                                (AttrChar -> AttrChar)
-> (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrChar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrCharW32 -> AttrChar
Color.attrCharFromW32
                    xs2High :: [AttrCharW32]
xs2High = case (AttrCharW32 -> AttrCharW32) -> [AttrCharW32] -> [AttrCharW32]
forall a b. (a -> b) -> [a] -> [b]
map AttrCharW32 -> AttrCharW32
highW32 [AttrCharW32]
xs2 of
                      [] -> []
                      xh :: AttrCharW32
xh : xhrest :: [AttrCharW32]
xhrest -> AttrCharW32 -> AttrCharW32
cursorW32 AttrCharW32
xh AttrCharW32 -> [AttrCharW32] -> [AttrCharW32]
forall a. a -> [a] -> [a]
: [AttrCharW32]
xhrest
                in [AttrCharW32]
xs1 [AttrCharW32] -> [AttrCharW32] -> [AttrCharW32]
forall a. [a] -> [a] -> [a]
++ [AttrCharW32]
xs2High [AttrCharW32] -> [AttrCharW32] -> [AttrCharW32]
forall a. [a] -> [a] -> [a]
++ [AttrCharW32]
xs3
              ov1 :: Overlay
ov1 = Y -> ([AttrCharW32] -> [AttrCharW32]) -> Overlay -> Overlay
updateLines Y
y [AttrCharW32] -> [AttrCharW32]
drawHighlight Overlay
ov
              ignoreKey :: m (Either KM SlotChar, Y)
ignoreKey = Y -> m (Either KM SlotChar, Y)
page Y
pointer
              pageLen :: Y
pageLen = [(Either [KM] SlotChar, (Y, Y, Y))] -> Y
forall a. [a] -> Y
length [(Either [KM] SlotChar, (Y, Y, Y))]
kyxs
              xix :: (Either [KM] SlotChar, (Y, Y, Y)) -> Bool
xix (_, (_, x1' :: Y
x1', _)) = Y
x1' Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
x1
              firstRowOfNextPage :: Y
firstRowOfNextPage = Y
pointer Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
pageLen Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
ixOnPage
              restOKX :: [(Either [KM] SlotChar, (Y, Y, Y))]
restOKX = Y
-> [(Either [KM] SlotChar, (Y, Y, Y))]
-> [(Either [KM] SlotChar, (Y, Y, Y))]
forall a. Y -> [a] -> [a]
drop Y
firstRowOfNextPage [(Either [KM] SlotChar, (Y, Y, Y))]
allOKX
              firstItemOfNextPage :: Y
firstItemOfNextPage = case ((Either [KM] SlotChar, (Y, Y, Y)) -> Bool)
-> [(Either [KM] SlotChar, (Y, Y, Y))] -> Maybe Y
forall a. (a -> Bool) -> [a] -> Maybe Y
findIndex (Either [KM] SlotChar -> Bool
forall a b. Either a b -> Bool
isRight (Either [KM] SlotChar -> Bool)
-> ((Either [KM] SlotChar, (Y, Y, Y)) -> Either [KM] SlotChar)
-> (Either [KM] SlotChar, (Y, Y, Y))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either [KM] SlotChar, (Y, Y, Y)) -> Either [KM] SlotChar
forall a b. (a, b) -> a
fst) [(Either [KM] SlotChar, (Y, Y, Y))]
restOKX of
                Just p :: Y
p -> Y
p Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
firstRowOfNextPage
                _ -> Y
firstRowOfNextPage
              interpretKey :: K.KM -> m (Either K.KM SlotChar, Int)
              interpretKey :: KM -> m (Either KM SlotChar, Y)
interpretKey ikm :: KM
ikm =
                case KM -> Key
K.key KM
ikm of
                  _ | KM
ikm KM -> KM -> Bool
forall a. Eq a => a -> a -> Bool
== KM
K.controlP -> do
                    -- Silent, because any prompt would be shown too late.
                    m ()
forall (m :: * -> *). MonadClientUI m => m ()
printScreen
                    m (Either KM SlotChar, Y)
ignoreKey
                  K.Return -> case Either [KM] SlotChar
ekm of
                    Left (km :: KM
km : _) ->
                      if KM -> Key
K.key KM
km Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
K.Return Bool -> Bool -> Bool
&& KM
km KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys
                      then (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (KM -> Either KM SlotChar
forall a b. a -> Either a b
Left KM
km, Y
pointer)
                      else KM -> m (Either KM SlotChar, Y)
interpretKey KM
km
                    Left [] -> [Char] -> m (Either KM SlotChar, Y)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Either KM SlotChar, Y))
-> [Char] -> m (Either KM SlotChar, Y)
forall a b. (a -> b) -> a -> b
$ "" [Char] -> KM -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` KM
ikm
                    Right c :: SlotChar
c -> (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotChar -> Either KM SlotChar
forall a b. b -> Either a b
Right SlotChar
c, Y
pointer)
                  K.LeftButtonRelease -> do
                    Point{..} <- (SessionUI -> Point) -> m Point
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Point
spointer
                    let onChoice :: (Either [KM] SlotChar, (Y, Y, Y)) -> Bool
onChoice (_, (cy :: Y
cy, cx1 :: Y
cx1, cx2 :: Y
cx2)) =
                          Y
cy Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
py Bool -> Bool -> Bool
&& Y
cx1 Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
<= Y
px Bool -> Bool -> Bool
&& Y
cx2 Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
> Y
px
                    case ((Either [KM] SlotChar, (Y, Y, Y)) -> Bool)
-> [(Either [KM] SlotChar, (Y, Y, Y))]
-> Maybe (Either [KM] SlotChar, (Y, Y, Y))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Either [KM] SlotChar, (Y, Y, Y)) -> Bool
onChoice [(Either [KM] SlotChar, (Y, Y, Y))]
kyxs of
                      Nothing | KM
ikm KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys -> (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (KM -> Either KM SlotChar
forall a b. a -> Either a b
Left KM
ikm, Y
pointer)
                      Nothing -> if KM
K.spaceKM KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys
                                 then (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (KM -> Either KM SlotChar
forall a b. a -> Either a b
Left KM
K.spaceKM, Y
pointer)
                                 else m (Either KM SlotChar, Y)
ignoreKey
                      Just (ckm :: Either [KM] SlotChar
ckm, _) -> case Either [KM] SlotChar
ckm of
                        Left (km :: KM
km : _) ->
                          if KM -> Key
K.key KM
km Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
K.Return Bool -> Bool -> Bool
&& KM
km KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys
                          then (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (KM -> Either KM SlotChar
forall a b. a -> Either a b
Left KM
km, Y
pointer)
                          else KM -> m (Either KM SlotChar, Y)
interpretKey KM
km
                        Left [] -> [Char] -> m (Either KM SlotChar, Y)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Either KM SlotChar, Y))
-> [Char] -> m (Either KM SlotChar, Y)
forall a b. (a -> b) -> a -> b
$ "" [Char] -> KM -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` KM
ikm
                        Right c :: SlotChar
c  -> (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotChar -> Either KM SlotChar
forall a b. b -> Either a b
Right SlotChar
c, Y
pointer)
                  K.RightButtonRelease ->
                    if | KM
ikm KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys -> (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (KM -> Either KM SlotChar
forall a b. a -> Either a b
Left KM
ikm, Y
pointer)
                       | KM
K.escKM KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys -> (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (KM -> Either KM SlotChar
forall a b. a -> Either a b
Left KM
K.escKM, Y
pointer)
                       | Bool
otherwise -> m (Either KM SlotChar, Y)
ignoreKey
                  K.Space | Y
firstItemOfNextPage Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
<= Y
maxIx ->
                    Y -> m (Either KM SlotChar, Y)
page Y
firstItemOfNextPage
                  K.Unknown "SAFE_SPACE" ->
                    if Y
firstItemOfNextPage Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
<= Y
maxIx
                    then Y -> m (Either KM SlotChar, Y)
page Y
firstItemOfNextPage
                    else Y -> m (Either KM SlotChar, Y)
page Y
clearIx
                  _ | KM
ikm KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys ->
                    (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (KM -> Either KM SlotChar
forall a b. a -> Either a b
Left KM
ikm, Y
pointer)
                  K.Up -> case ((Either [KM] SlotChar, (Y, Y, Y)) -> Bool)
-> [(Either [KM] SlotChar, (Y, Y, Y))] -> Maybe Y
forall a. (a -> Bool) -> [a] -> Maybe Y
findIndex (Either [KM] SlotChar, (Y, Y, Y)) -> Bool
xix ([(Either [KM] SlotChar, (Y, Y, Y))] -> Maybe Y)
-> [(Either [KM] SlotChar, (Y, Y, Y))] -> Maybe Y
forall a b. (a -> b) -> a -> b
$ [(Either [KM] SlotChar, (Y, Y, Y))]
-> [(Either [KM] SlotChar, (Y, Y, Y))]
forall a. [a] -> [a]
reverse ([(Either [KM] SlotChar, (Y, Y, Y))]
 -> [(Either [KM] SlotChar, (Y, Y, Y))])
-> [(Either [KM] SlotChar, (Y, Y, Y))]
-> [(Either [KM] SlotChar, (Y, Y, Y))]
forall a b. (a -> b) -> a -> b
$ Y
-> [(Either [KM] SlotChar, (Y, Y, Y))]
-> [(Either [KM] SlotChar, (Y, Y, Y))]
forall a. Y -> [a] -> [a]
take Y
ixOnPage [(Either [KM] SlotChar, (Y, Y, Y))]
kyxs of
                    Nothing -> KM -> m (Either KM SlotChar, Y)
interpretKey KM
ikm{key :: Key
K.key=Key
K.Left}
                    Just ix :: Y
ix -> Y -> m (Either KM SlotChar, Y)
page (Y -> Y -> Y
forall a. Ord a => a -> a -> a
max 0 (Y
pointer Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
ix Y -> Y -> Y
forall a. Num a => a -> a -> a
- 1))
                  K.Left -> if Y
pointer Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then Y -> m (Either KM SlotChar, Y)
page Y
maxIx
                            else Y -> m (Either KM SlotChar, Y)
page (Y -> Y -> Y
forall a. Ord a => a -> a -> a
max 0 (Y
pointer Y -> Y -> Y
forall a. Num a => a -> a -> a
- 1))
                  K.Down -> case ((Either [KM] SlotChar, (Y, Y, Y)) -> Bool)
-> [(Either [KM] SlotChar, (Y, Y, Y))] -> Maybe Y
forall a. (a -> Bool) -> [a] -> Maybe Y
findIndex (Either [KM] SlotChar, (Y, Y, Y)) -> Bool
xix ([(Either [KM] SlotChar, (Y, Y, Y))] -> Maybe Y)
-> [(Either [KM] SlotChar, (Y, Y, Y))] -> Maybe Y
forall a b. (a -> b) -> a -> b
$ Y
-> [(Either [KM] SlotChar, (Y, Y, Y))]
-> [(Either [KM] SlotChar, (Y, Y, Y))]
forall a. Y -> [a] -> [a]
drop (Y
ixOnPage Y -> Y -> Y
forall a. Num a => a -> a -> a
+ 1) [(Either [KM] SlotChar, (Y, Y, Y))]
kyxs of
                    Nothing -> KM -> m (Either KM SlotChar, Y)
interpretKey KM
ikm{key :: Key
K.key=Key
K.Right}
                    Just ix :: Y
ix -> Y -> m (Either KM SlotChar, Y)
page (Y
pointer Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
ix Y -> Y -> Y
forall a. Num a => a -> a -> a
+ 1)
                  K.Right -> if Y
pointer Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
maxIx then Y -> m (Either KM SlotChar, Y)
page 0
                             else Y -> m (Either KM SlotChar, Y)
page (Y -> Y -> Y
forall a. Ord a => a -> a -> a
min Y
maxIx (Y
pointer Y -> Y -> Y
forall a. Num a => a -> a -> a
+ 1))
                  K.Home -> Y -> m (Either KM SlotChar, Y)
page Y
clearIx
                  K.End -> Y -> m (Either KM SlotChar, Y)
page Y
maxIx
                  _ | KM -> Key
K.key KM
ikm Key -> [Key] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key
K.PgUp, Key
K.WheelNorth] ->
                    Y -> m (Either KM SlotChar, Y)
page (Y -> Y -> Y
forall a. Ord a => a -> a -> a
max 0 (Y
pointer Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
ixOnPage Y -> Y -> Y
forall a. Num a => a -> a -> a
- 1))
                  _ | KM -> Key
K.key KM
ikm Key -> [Key] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key
K.PgDn, Key
K.WheelSouth] ->
                    Y -> m (Either KM SlotChar, Y)
page (Y -> Y -> Y
forall a. Ord a => a -> a -> a
min Y
maxIx Y
firstItemOfNextPage)
                  K.Space -> if Y
pointer Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
maxIx then Y -> m (Either KM SlotChar, Y)
page Y
clearIx
                             else Y -> m (Either KM SlotChar, Y)
page Y
maxIx
                  _ -> [Char] -> m (Either KM SlotChar, Y)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Either KM SlotChar, Y))
-> [Char] -> m (Either KM SlotChar, Y)
forall a b. (a -> b) -> a -> b
$ "unknown key" [Char] -> KM -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` KM
ikm
          KM
pkm <- ColorMode -> Overlay -> Bool -> [KM] -> m KM
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> Overlay -> Bool -> [KM] -> m KM
promptGetKey ColorMode
dm Overlay
ov1 Bool
sfBlank [KM]
legalKeys
          KM -> m (Either KM SlotChar, Y)
interpretKey KM
pkm
  Map [Char] Y
menuIxMap <- (SessionUI -> Map [Char] Y) -> m (Map [Char] Y)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Map [Char] Y
smenuIxMap
  -- Beware, values in @menuIxMap@ may be negative (meaning: a key, not slot).
  let menuIx :: Y
menuIx | [Char]
menuName [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== "" = Y
clearIx
             | Bool
otherwise =
               Y -> (Y -> Y) -> Maybe Y -> Y
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Y
clearIx (Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
initIx) ([Char] -> Map [Char] Y -> Maybe Y
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
menuName Map [Char] Y
menuIxMap)
                 -- this may be negative, from different context
  (km :: Either KM SlotChar
km, pointer :: Y
pointer) <- if [OKX] -> Bool
forall a. [a] -> Bool
null [OKX]
frs
                   then (Either KM SlotChar, Y) -> m (Either KM SlotChar, Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (KM -> Either KM SlotChar
forall a b. a -> Either a b
Left KM
K.escKM, Y
menuIx)
                   else Y -> m (Either KM SlotChar, Y)
page (Y -> m (Either KM SlotChar, Y)) -> Y -> m (Either KM SlotChar, Y)
forall a b. (a -> b) -> a -> b
$ Y -> Y -> Y
forall a. Ord a => a -> a -> a
max Y
clearIx (Y -> Y) -> Y -> Y
forall a b. (a -> b) -> a -> b
$ Y -> Y -> Y
forall a. Ord a => a -> a -> a
min Y
maxIx Y
menuIx
                          -- the saved index could be from different context
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char]
menuName [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== "") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \sess :: SessionUI
sess ->
      SessionUI
sess {smenuIxMap :: Map [Char] Y
smenuIxMap = [Char] -> Y -> Map [Char] Y -> Map [Char] Y
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
menuName (Y
pointer Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
initIx) Map [Char] Y
menuIxMap}
  Bool -> m (Either KM SlotChar) -> m (Either KM SlotChar)
forall a. HasCallStack => Bool -> a -> a
assert ((KM -> Bool) -> (SlotChar -> Bool) -> Either KM SlotChar -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys) (Bool -> SlotChar -> Bool
forall a b. a -> b -> a
const Bool
True) Either KM SlotChar
km) (m (Either KM SlotChar) -> m (Either KM SlotChar))
-> m (Either KM SlotChar) -> m (Either KM SlotChar)
forall a b. (a -> b) -> a -> b
$ Either KM SlotChar -> m (Either KM SlotChar)
forall (m :: * -> *) a. Monad m => a -> m a
return Either KM SlotChar
km