InventoryM.hs

-- | UI of inventory management.
module Game.LambdaHack.Client.UI.InventoryM
  ( Suitability(..), ResultItemDialogMode(..)
  , slotsOfItemDialogMode, getFull, getGroupItem, getStoreItem
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , ItemDialogState(..), accessModeBag, storeItemPrompt, getItem
  , DefItemKey(..), transition, keyOfEKM, runDefItemKey
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.Char as Char
import           Data.Either
import qualified Data.EnumMap.Strict as EM
import qualified Data.Text as T
import qualified NLP.Miniutter.English as MU

import           Game.LambdaHack.Client.MonadClient
import           Game.LambdaHack.Client.State
import           Game.LambdaHack.Client.UI.ActorUI
import           Game.LambdaHack.Client.UI.Content.Screen
import           Game.LambdaHack.Client.UI.ContentClientUI
import           Game.LambdaHack.Client.UI.Frame
import           Game.LambdaHack.Client.UI.HandleHelperM
import           Game.LambdaHack.Client.UI.HumanCmd
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.Msg
import           Game.LambdaHack.Client.UI.MsgM
import           Game.LambdaHack.Client.UI.SessionUI
import           Game.LambdaHack.Client.UI.Slideshow
import           Game.LambdaHack.Client.UI.SlideshowM
import           Game.LambdaHack.Common.Actor
import           Game.LambdaHack.Common.ActorState
import           Game.LambdaHack.Common.Faction
import           Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import           Game.LambdaHack.Common.Kind
import           Game.LambdaHack.Common.Misc
import           Game.LambdaHack.Common.MonadStateRead
import           Game.LambdaHack.Common.State
import           Game.LambdaHack.Common.Types
import qualified Game.LambdaHack.Content.ItemKind as IK
import qualified Game.LambdaHack.Definition.Ability as Ability
import           Game.LambdaHack.Definition.Defs

data ItemDialogState = ISuitable | IAll
  deriving (Show, Eq)

data ResultItemDialogMode =
    RStore CStore [ItemId]
  | ROrgans ItemId ItemBag SingleItemSlots
  | ROwned ItemId
  | RSkills Int
  | RLore SLore ItemId ItemBag SingleItemSlots
  | RPlaces Int
  | RModes Int
  deriving Show

accessModeBag :: ActorId -> State -> ItemDialogMode -> ItemBag
accessModeBag leader s (MStore cstore) = let b = getActorBody leader s
                                         in getBodyStoreBag b cstore s
accessModeBag leader s MOrgans = let b = getActorBody leader s
                                 in getBodyStoreBag b COrgan s
accessModeBag leader s MOwned = let fid = bfid $ getActorBody leader s
                                in combinedItems fid s
accessModeBag _ _ MSkills = EM.empty
accessModeBag _ s MLore{} = EM.map (const quantSingle) $ sitemD s
accessModeBag _ _ MPlaces = EM.empty
accessModeBag _ _ MModes = EM.empty

-- This is the only place slots are sorted. As a side-effect,
-- slots in inventories always agree with slots of item lore.
-- Not so for organ menu, because many lore maps point there.
-- Sorting in @updateItemSlot@ would not be enough, because, e.g.,
-- identifying an item should change its slot position.
slotsOfItemDialogMode :: MonadClientUI m => ItemDialogMode -> m SingleItemSlots
slotsOfItemDialogMode cCur = do
  itemToF <- getsState $ flip itemToFull
  ItemSlots itemSlotsPre <- getsSession sslots
  case cCur of
    MOrgans -> do
      let newSlots = EM.adjust (sortSlotMap itemToF) SOrgan
                     $ EM.adjust (sortSlotMap itemToF) STrunk
                     $ EM.adjust (sortSlotMap itemToF) SCondition itemSlotsPre
      modifySession $ \sess -> sess {sslots = ItemSlots newSlots}
      return $! mergeItemSlots itemToF [ newSlots EM.! SOrgan
                                       , newSlots EM.! STrunk
                                       , newSlots EM.! SCondition ]
    MSkills -> return EM.empty
    MPlaces -> return EM.empty
    MModes -> return EM.empty
    _ -> do
      let slore = IA.loreFromMode cCur
          newSlots = EM.adjust (sortSlotMap itemToF) slore itemSlotsPre
      modifySession $ \sess -> sess {sslots = ItemSlots newSlots}
      return $! newSlots EM.! slore

-- | Let a human player choose any item from a given group.
-- Note that this does not guarantee the chosen item belongs to the group,
-- as the player can override the choice.
-- Used e.g., for applying and projecting.
getGroupItem :: (MonadClient m, MonadClientUI m)
             => m Suitability
                          -- ^ which items to consider suitable
             -> Text      -- ^ specific prompt for only suitable items
             -> Text      -- ^ generic prompt
             -> Text      -- ^ the verb to use
             -> Text      -- ^ the generic verb to use
             -> [CStore]  -- ^ stores to cycle through
             -> m (Either Text (CStore, ItemId))
getGroupItem psuit prompt promptGeneric verb verbGeneric stores = do
  side <- getsClient sside
  mstash <- getsState $ \s -> gstash $ sfactionD s EM.! side
  let ppItemDialogBody v body actorSk cCur = case cCur of
        MStore CEqp | not $ calmEnough body actorSk ->
          "distractedly attempt to" <+> v <+> ppItemDialogModeIn cCur
        MStore CGround | mstash == Just (blid body, bpos body) ->
          "greedily attempt to" <+> v <+> ppItemDialogModeIn cCur
        _ -> v <+> ppItemDialogModeFrom cCur
  soc <- getFull psuit
                 (\body _ actorSk cCur _ ->
                    prompt <+> ppItemDialogBody verb body actorSk cCur)
                 (\body _ actorSk cCur _ ->
                    promptGeneric
                    <+> ppItemDialogBody verbGeneric body actorSk cCur)
                 stores True False
  case soc of
    Left err -> return $ Left err
    Right (rstore, [(iid, _)]) -> return $ Right (rstore, iid)
    Right _ -> error $ "" `showFailure` soc

-- | Display all items from a store and let the human player choose any
-- or switch to any other store.
-- Used, e.g., for viewing inventory and item descriptions.
getStoreItem :: (MonadClient m, MonadClientUI m)
             => ItemDialogMode   -- ^ initial mode
             -> m (Either Text ResultItemDialogMode)
getStoreItem cInitial = do
  side <- getsClient sside
  let itemCs = map MStore [CStash, CEqp, CGround]
        -- No @COrgan@, because triggerable organs are rare and,
        -- if really needed, accessible directly from the trigger menu.
      loreCs = map MLore [minBound..maxBound] ++ [MPlaces, MModes]
      allCs = case cInitial of
        MLore{} -> loreCs
        MPlaces -> loreCs
        MModes -> loreCs
        _ -> itemCs ++ [MOwned, MOrgans, MSkills]
      (pre, rest) = break (== cInitial) allCs
      post = dropWhile (== cInitial) rest
      remCs = post ++ pre
      prompt = storeItemPrompt side
  getItem (return SuitsEverything) prompt prompt cInitial remCs True False

storeItemPrompt :: FactionId
                -> Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
                -> Text
storeItemPrompt side body bodyUI actorCurAndMaxSk c2 s =
  let COps{coitem} = scops s
      fact = sfactionD s EM.! side
      (tIn, t) = ppItemDialogMode c2
      subject = partActor bodyUI
      f (k, _) acc = k + acc
      countItems store = EM.foldr' f 0 $ getBodyStoreBag body store s
  in case c2 of
    MStore CGround ->
      let n = countItems CGround
          nItems = MU.CarAWs n "item"
          verbGround = if gstash fact == Just (blid body, bpos body)
                       then "fondle greedily"
                       else "notice"
      in makePhrase
           [ MU.Capitalize $ MU.SubjectVerbSg subject verbGround
           , nItems, "at"
           , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text "feet" ]
    MStore CEqp ->
      let n = countItems CEqp
          (verbEqp, nItems) =
            if | n == 0 -> ("find nothing", "")
               | calmEnough body actorCurAndMaxSk ->
                   ("find", MU.CarAWs n "item")
               | otherwise -> ("paw distractedly at", MU.CarAWs n "item")
      in makePhrase
           [ MU.Capitalize $ MU.SubjectVerbSg subject verbEqp
           , nItems, MU.Text tIn
           , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]
    MStore cstore ->
      let n = countItems cstore
          nItems = MU.CarAWs n "item"
          (verb, onLevel) = case cstore of
            COrgan -> ("feel", [])
            CStash ->
              ( "notice"
              , case gstash fact of
                  Just (lid, _) ->
                    map MU.Text ["on level", tshow $ abs $ fromEnum lid]
                  Nothing -> [] )
            _ -> ("see", [])
          ownObject = case cstore of
            CStash -> ["our", MU.Text t]
            _ -> [MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t]
      in makePhrase $
           [ MU.Capitalize $ MU.SubjectVerbSg subject verb
           , nItems, MU.Text tIn ] ++ ownObject ++ onLevel
    MOrgans ->
      makePhrase
        [ MU.Capitalize $ MU.SubjectVerbSg subject "feel"
        , MU.Text tIn
        , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]
    MOwned ->
      -- We assume "gold grain", not "grain" with label "of gold":
      let currencyName = IK.iname $ okind coitem
                         $ ouniqGroup coitem IK.S_CURRENCY
          dungeonTotal = sgold s
          (_, total) = calculateTotal side s
          n = countItems CStash
          verbOwned = if | n == 0 -> "find nothing among"
                         | otherwise -> "review"
      in makePhrase
           [ MU.Text $ spoilsBlurb currencyName total dungeonTotal
           , MU.Capitalize $ MU.SubjectVerbSg subject verbOwned
           , MU.Text t ]
    MSkills ->
      makePhrase
        [ MU.Capitalize $ MU.SubjectVerbSg subject "estimate"
        , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]
    MLore slore ->
      makePhrase
        [ MU.Capitalize $ MU.Text $
            if slore == SEmbed
            then "terrain (including crafting recipes)"
            else t ]
    MPlaces ->
      makePhrase
        [ MU.Capitalize $ MU.Text t ]
    MModes ->
      makePhrase
        [ MU.Capitalize $ MU.Text t ]

-- | Let the human player choose a single, preferably suitable,
-- item from a list of items. Don't display stores empty for all actors.
-- Start with a non-empty store.
getFull :: (MonadClient m, MonadClientUI m)
        => m Suitability    -- ^ which items to consider suitable
        -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
            -> Text)        -- ^ specific prompt for only suitable items
        -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
            -> Text)        -- ^ generic prompt
        -> [CStore]         -- ^ stores to cycle through
        -> Bool             -- ^ whether to ask, when the only item
                            --   in the starting mode is suitable
        -> Bool             -- ^ whether to permit multiple items as a result
        -> m (Either Text (CStore, [(ItemId, ItemQuant)]))
getFull psuit prompt promptGeneric stores askWhenLone permitMulitple = do
  leader <- getLeaderUI
  mpsuit <- psuit
  let psuitFun = case mpsuit of
        SuitsEverything -> \_ _ _ -> True
        SuitsSomething f -> f
  -- Move the first store that is non-empty for suitable items for this actor
  -- to the front, if any.
  b <- getsState $ getActorBody leader
  getCStoreBag <- getsState $ \s cstore -> getBodyStoreBag b cstore s
  let hasThisActor = not . EM.null . getCStoreBag
  case filter hasThisActor stores of
    [] -> do
      let dialogModes = map MStore stores
          ts = map (MU.Text . ppItemDialogModeIn) dialogModes
      return $ Left $ "no items" <+> makePhrase [MU.WWxW "nor" ts]
    haveThis@(headThisActor : _) -> do
      itemToF <- getsState $ flip itemToFull
      let suitsThisActor store =
            let bag = getCStoreBag store
            in any (\(iid, kit) -> psuitFun (Just store) (itemToF iid) kit)
                   (EM.assocs bag)
          firstStore = fromMaybe headThisActor $ find suitsThisActor haveThis
          -- Don't display stores totally empty for all actors.
          breakStores cInit =
            let (pre, rest) = break (== cInit) stores
                post = dropWhile (== cInit) rest
            in (MStore cInit, map MStore $ post ++ pre)
          (modeFirst, modeRest) = breakStores firstStore
      res <- getItem psuit prompt promptGeneric modeFirst modeRest
                     askWhenLone permitMulitple
      case res of
        Left t -> return $ Left t
        Right (RStore fromCStore iids) -> do
          let bagAll = getCStoreBag fromCStore
              f iid = (iid, bagAll EM.! iid)
          return $ Right (fromCStore, map f iids)
        Right _ -> error $ "" `showFailure` res

-- | Let the human player choose a single, preferably suitable,
-- item from a list of items.
getItem :: (MonadClient m, MonadClientUI m)
        => m Suitability    -- ^ which items to consider suitable
        -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
            -> Text)        -- ^ specific prompt for only suitable items
        -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
            -> Text)        -- ^ generic prompt
        -> ItemDialogMode   -- ^ first mode to display
        -> [ItemDialogMode] -- ^ the (rest of) modes
        -> Bool             -- ^ whether to ask, when the only item
                            --   in the starting mode is suitable
        -> Bool             -- ^ whether to permit multiple items as a result
        -> m (Either Text ResultItemDialogMode)
getItem psuit prompt promptGeneric cCur cRest askWhenLone permitMulitple = do
  leader <- getLeaderUI
  accessCBag <- getsState $ accessModeBag leader
  let storeAssocs = EM.assocs . accessCBag
      allAssocs = concatMap storeAssocs (cCur : cRest)
  case (allAssocs, cCur) of
    ([(iid, _)], MStore rstore) | null cRest && not askWhenLone ->
      return $ Right $ RStore rstore [iid]
    _ -> transition psuit prompt promptGeneric permitMulitple
                    0 cCur cRest ISuitable

data DefItemKey m = DefItemKey
  { defLabel  :: Either Text K.KM
  , defCond   :: Bool
  , defAction :: Either K.KM SlotChar -> m (Either Text ResultItemDialogMode)
  }

data Suitability =
    SuitsEverything
  | SuitsSomething (Maybe CStore -> ItemFull -> ItemQuant -> Bool)

transition :: forall m. (MonadClient m, MonadClientUI m)
           => m Suitability
           -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
               -> Text)
           -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
               -> Text)
           -> Bool
           -> Int
           -> ItemDialogMode
           -> [ItemDialogMode]
           -> ItemDialogState
           -> m (Either Text ResultItemDialogMode)
transition psuit prompt promptGeneric permitMulitple
           numPrefix cCur cRest itemDialogState = do
  let recCall = transition psuit prompt promptGeneric permitMulitple
  leader <- getLeaderUI
  actorCurAndMaxSk <- leaderSkillsClientUI
  body <- getsState $ getActorBody leader
  bodyUI <- getsSession $ getActorUI leader
  fact <- getsState $ (EM.! bfid body) . sfactionD
  hs <- partyAfterLeader leader
  bagAll <- getsState $ \s -> accessModeBag leader s cCur
  itemToF <- getsState $ flip itemToFull
  revCmd <- revCmdMap
  mpsuit <- psuit  -- when throwing, this sets eps and checks xhair validity
  psuitFun <- case mpsuit of
    SuitsEverything -> return $ \_ _ _ -> True
    SuitsSomething f -> return f  -- When throwing, this function takes
                                  -- missile range into accout.
  lSlots <- slotsOfItemDialogMode cCur
  let getResult :: [ItemId] -> Either Text ResultItemDialogMode
      getResult iids = Right $ case cCur of
        MStore rstore -> RStore rstore iids
        MOrgans -> case iids of
          [iid] -> ROrgans iid bagAll bagItemSlotsAll
          _ -> error $ "" `showFailure` (cCur, iids)
        MOwned -> case iids of
          [iid] -> ROwned iid
          _ -> error $ "" `showFailure` (cCur, iids)
        MSkills -> error $ "" `showFailure` cCur
        MLore rlore -> case iids of
          [iid] -> RLore rlore iid bagAll bagItemSlotsAll
          _ -> error $ "" `showFailure` (cCur, iids)
        MPlaces ->  error $ "" `showFailure` cCur
        MModes -> error $ "" `showFailure` cCur
      mstore = case cCur of
        MStore store -> Just store
        _ -> Nothing
      filterP iid = psuitFun mstore (itemToF iid)
      bagAllSuit = EM.filterWithKey filterP bagAll
      bagItemSlotsAll = EM.filter (`EM.member` bagAll) lSlots
      -- Predicate for slot matching the current prefix, unless the prefix
      -- is 0, in which case we display all slots, even if they require
      -- the user to start with number keys to get to them.
      -- Could be generalized to 1 if prefix 1x exists, etc., but too rare.
      hasPrefixOpen x _ = slotPrefix x == numPrefix || numPrefix == 0
      bagItemSlotsOpen = EM.filterWithKey hasPrefixOpen bagItemSlotsAll
      hasPrefix x _ = slotPrefix x == numPrefix
      bagItemSlots = EM.filterWithKey hasPrefix bagItemSlotsOpen
      bag = EM.fromList $ map (\iid -> (iid, bagAll EM.! iid))
                              (EM.elems bagItemSlotsOpen)
      suitableItemSlotsAll = EM.filter (`EM.member` bagAllSuit) lSlots
      suitableItemSlotsOpen =
        EM.filterWithKey hasPrefixOpen suitableItemSlotsAll
      bagSuit = EM.fromList $ map (\iid -> (iid, bagAllSuit EM.! iid))
                                  (EM.elems suitableItemSlotsOpen)
      nextContainers direction = case direction of
        Forward -> case cRest ++ [cCur] of
          c1 : rest -> (c1, rest)
          [] -> error $ "" `showFailure` cRest
        Backward -> case reverse $ cCur : cRest of
          c1 : rest -> (c1, reverse rest)
          [] -> error $ "" `showFailure` cRest
  (bagFiltered, promptChosen) <- getsState $ \s ->
    case itemDialogState of
      ISuitable -> (bagSuit, prompt body bodyUI actorCurAndMaxSk cCur s <> ":")
      IAll -> (bag, promptGeneric body bodyUI actorCurAndMaxSk cCur s <> ":")
  let (autoDun, _) = autoDungeonLevel fact
      multipleSlots = if itemDialogState == IAll
                      then bagItemSlotsAll
                      else suitableItemSlotsAll
      maySwitchLeader MOwned = False
      maySwitchLeader MLore{} = False
      maySwitchLeader MPlaces = False
      maySwitchLeader MModes = False
      maySwitchLeader _ = True
      cycleKeyDef direction =
        let km = revCmd $ MemberCycle direction
        in (km, DefItemKey
               { defLabel = if direction == Forward then Right km else Left ""
               , defCond = maySwitchLeader cCur && not (autoDun || null hs)
               , defAction = \_ -> do
                   err <- memberCycle False direction
                   let !_A = assert (isNothing err `blame` err) ()
                   recCall numPrefix cCur cRest itemDialogState
               })
      cycleLevelKeyDef direction =
        let km = revCmd $ MemberCycleLevel direction
        in (km, DefItemKey
                { defLabel = Left ""
                , defCond = maySwitchLeader cCur
                            && any (\(_, b, _) -> blid b == blid body) hs
                , defAction = \_ -> do
                    err <- memberCycleLevel False direction
                    let !_A = assert (isNothing err `blame` err) ()
                    recCall numPrefix cCur cRest itemDialogState
                })
      keyDefs :: [(K.KM, DefItemKey m)]
      keyDefs = filter (defCond . snd) $
        [ let km = K.mkChar '<'
          in (km, changeContainerDef Backward $ Right km)
        , let km = K.mkChar '>'
          in (km, changeContainerDef Forward $ Right km)
        , let km = K.mkChar '+'
          in (km, DefItemKey
           { defLabel = Right km
           , defCond = bag /= bagSuit
           , defAction = \_ -> recCall numPrefix cCur cRest
                               $ case itemDialogState of
                                   ISuitable -> IAll
                                   IAll -> ISuitable
           })
        , let km = K.mkChar '*'
          in (km, useMultipleDef $ Right km)
        , let km = K.mkChar '!'
          in (km, useMultipleDef $ Left "")  -- alias close to 'g'
        , cycleKeyDef Forward
        , cycleKeyDef Backward
        , cycleLevelKeyDef Forward
        , cycleLevelKeyDef Backward
        , (K.KM K.NoModifier K.LeftButtonRelease, DefItemKey
           { defLabel = Left ""
           , defCond = maySwitchLeader cCur && not (null hs)
           , defAction = \_ -> do
               merror <- pickLeaderWithPointer
               case merror of
                 Nothing -> recCall numPrefix cCur cRest itemDialogState
                 Just{} -> return $ Left "not a menu item nor teammate position"
                             -- don't inspect the error, it's expected
           })
        , (K.escKM, DefItemKey
           { defLabel = Right K.escKM
           , defCond = True
           , defAction = \_ -> return $ Left "never mind"
           })
        ]
        ++ numberPrefixes
      changeContainerDef direction defLabel =
        let (cCurAfterCalm, cRestAfterCalm) = nextContainers direction
        in DefItemKey
          { defLabel
          , defCond = cCurAfterCalm /= cCur
          , defAction = \_ ->
              recCall numPrefix cCurAfterCalm cRestAfterCalm itemDialogState
          }
      useMultipleDef defLabel = DefItemKey
        { defLabel
        , defCond = permitMulitple && not (EM.null multipleSlots)
        , defAction = \_ ->
            let eslots = EM.elems multipleSlots
            in return $! getResult eslots
        }
      prefixCmdDef d =
        (K.mkChar $ Char.intToDigit d, DefItemKey
           { defLabel = Left ""
           , defCond = True
           , defAction = \_ ->
               recCall (10 * numPrefix + d) cCur cRest itemDialogState
           })
      numberPrefixes = map prefixCmdDef [0..9]
      lettersDef :: DefItemKey m
      lettersDef = DefItemKey
        { defLabel = Left ""
        , defCond = True
        , defAction = \ekm ->
            let slot = case ekm of
                  Left K.KM{key=K.Char l} -> SlotChar numPrefix l
                  Left km ->
                    error $ "unexpected key:" `showFailure` K.showKM km
                  Right sl -> sl
            in case EM.lookup slot bagItemSlotsAll of
              Nothing -> error $ "unexpected slot"
                                 `showFailure` (slot, bagItemSlots)
              Just iid -> return $! getResult [iid]
        }
      processSpecialOverlay :: OKX -> (Int -> ResultItemDialogMode)
                            -> m (Either Text ResultItemDialogMode)
      processSpecialOverlay io resultConstructor = do
        let slotLabels = map fst $ snd io
            slotKeys = mapMaybe (keyOfEKM numPrefix) slotLabels
            skillsDef :: DefItemKey m
            skillsDef = DefItemKey
              { defLabel = Left ""
              , defCond = True
              , defAction = \ekm ->
                  let slot = case ekm of
                        Left K.KM{key} -> case key of
                          K.Char l -> SlotChar numPrefix l
                          _ -> error $ "unexpected key:"
                                       `showFailure` K.showKey key
                        Right sl -> sl
                      slotIndex = fromMaybe (error "illegal slot")
                                  $ elemIndex slot allSlots
                  in return (Right (resultConstructor slotIndex))
              }
        runDefItemKey keyDefs skillsDef io slotKeys promptChosen cCur
  case cCur of
    MSkills -> do
      io <- skillsOverlay leader
      processSpecialOverlay io RSkills
    MPlaces -> do
      io <- placesOverlay
      processSpecialOverlay io RPlaces
    MModes -> do
      io <- modesOverlay
      processSpecialOverlay io RModes
    _ -> do
      let displayRanged =
            cCur `notElem` [MStore COrgan, MOrgans, MLore SOrgan, MLore STrunk]
      io <- itemOverlay lSlots (blid body) bagFiltered displayRanged
      let slotKeys = mapMaybe (keyOfEKM numPrefix . Right)
                     $ EM.keys bagItemSlots
      runDefItemKey keyDefs lettersDef io slotKeys promptChosen cCur

keyOfEKM :: Int -> Either [K.KM] SlotChar -> Maybe K.KM
keyOfEKM _ (Left kms) = error $ "" `showFailure` kms
keyOfEKM numPrefix (Right SlotChar{..}) | slotPrefix == numPrefix =
  Just $ K.mkChar slotChar
keyOfEKM _ _ = Nothing

-- We don't create keys from slots in @okx@, so they have to be
-- exolicitly given in @slotKeys@.
runDefItemKey :: (MonadClient m, MonadClientUI m)
              => [(K.KM, DefItemKey m)]
              -> DefItemKey m
              -> OKX
              -> [K.KM]
              -> Text
              -> ItemDialogMode
              -> m (Either Text ResultItemDialogMode)
runDefItemKey keyDefs lettersDef okx slotKeys prompt cCur = do
  let itemKeys = slotKeys ++ map fst keyDefs
      wrapB s = "[" <> s <> "]"
      (keyLabelsRaw, keys) = partitionEithers $ map (defLabel . snd) keyDefs
      keyLabels = filter (not . T.null) keyLabelsRaw
      choice = T.intercalate " " $ map wrapB $ nub keyLabels
        -- switch to Data.Containers.ListUtils.nubOrd when we drop GHC 8.4.4
  msgAdd MsgPromptGeneric $ prompt <+> choice
  CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui
  ekm <- do
    okxs <- overlayToSlideshow (rheight - 2) keys okx
    displayChoiceScreen (show cCur) ColorFull False okxs itemKeys
  case ekm of
    Left km -> case km `lookup` keyDefs of
      Just keyDef -> defAction keyDef ekm
      Nothing -> defAction lettersDef ekm  -- pressed; with current prefix
    Right _slot -> defAction lettersDef ekm  -- selected; with the given prefix