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
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
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
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 ([], [])
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
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 ([], [])
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
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
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
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
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
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
[] ->
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 ->
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
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
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
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)
(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
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