{-# LANGUAGE OverloadedStrings #-}

module NanoUI.Widgets.Menu
  ( contextMenu
  , contextMenuArea
  , useContextMenu
  , menuButton
  , menuButton'
  , MenuItem (..)
  , menuItemWith
  , menuItem
  , menuItem'
  , menuItemShortcut
  , menuItemDisabled
  , menuSeparator
  , menuHeader
  )
where

import Control.Monad (void, when)
import Data.IntMap.Strict qualified as IM
import Data.Text (Text)
import Effectful (Eff, type (:>))
import NanoUI.Context (Context (..), getStore, intKey, modifyStore)
import NanoUI.Font (menuItemPadX, menuItemRowH, menuMinW, menuOuterPad, menuSepH, widgetContentInset)
import NanoUI.Input (inputMousePos, inputMouseReleased)
import NanoUI.Monad (Ui, askContext, askDefaultLayout, askInput, nextId, uiIO)
import NanoUI.Store (WidgetStore (..), slotKey, Slot (..))
import NanoUI.Style (Layout (..), Padding (..), defaultLayout, fillW, fixedH, fontMuted, gap, minW, padXY, tight)
import NanoUI.Types (PopupAnchor (..), PopupPlacement (..), V2 (..))
import NanoUI.WidgetText (buttonFlagMenu, buttonFlagMenuBar)
import NanoUI.Widgets.Combinators (buttonStyled)
import NanoUI.Widgets.Layout (columnWith, labelEx, rowWith, separator)
import NanoUI.Layout.Arena (NodeType (..))
import NanoUI.Widgets.Node (HasResponse, Response (..), containerResponse, respClicked, respHovered, respRightClicked)
import NanoUI.Widgets.Popup (PopupConfig (..), popup)

-- | A context menu for any widget response, opened by right-clicking it.
-- Returns the menu body's result while the menu is open.
contextMenu ::
  (Ui :> es, HasResponse r) =>
  r ->
  Eff es a ->
  Eff es (Maybe a)
contextMenu :: forall (es :: [Effect]) r a.
(Ui :> es, HasResponse r) =>
r -> Eff es a -> Eff es (Maybe a)
contextMenu r
target Eff es a
child = do
  menu <- Eff es (Bool, V2, V2 -> Eff es (), Eff es ())
forall (es :: [Effect]).
(Ui :> es) =>
Eff es (Bool, V2, V2 -> Eff es (), Eff es ())
useContextMenu
  runContextMenu menu (respRightClicked target) (const child)

-- | A container whose right-click opens a context menu. The menu body
-- receives the position it was opened at.
contextMenuArea ::
  Ui :> es =>
  (Layout -> Layout) ->
  Eff es a ->
  (V2 -> Eff es b) ->
  Eff es (a, Maybe b)
contextMenuArea :: forall (es :: [Effect]) a b.
(Ui :> es) =>
(Layout -> Layout)
-> Eff es a -> (V2 -> Eff es b) -> Eff es (a, Maybe b)
contextMenuArea Layout -> Layout
f Eff es a
areaContent V2 -> Eff es b
menuContent = do
  menu <- Eff es (Bool, V2, V2 -> Eff es (), Eff es ())
forall (es :: [Effect]).
(Ui :> es) =>
Eff es (Bool, V2, V2 -> Eff es (), Eff es ())
useContextMenu
  base <- askDefaultLayout
  (areaRes, areaResp) <- containerResponse NodeContainer (f base) areaContent
  (,) areaRes <$> runContextMenu menu (respRightClicked areaResp) menuContent

-- | Open the menu at the pointer on a right click, show it while open, and
-- close it once a row is picked or it is dismissed.
runContextMenu ::
  Ui :> es =>
  (Bool, V2, V2 -> Eff es (), Eff es ()) ->
  Bool ->
  (V2 -> Eff es a) ->
  Eff es (Maybe a)
runContextMenu :: forall (es :: [Effect]) a.
(Ui :> es) =>
(Bool, V2, V2 -> Eff es (), Eff es ())
-> Bool -> (V2 -> Eff es a) -> Eff es (Maybe a)
runContextMenu (Bool
isOpen0, V2
pos0, V2 -> Eff es ()
openAt, Eff es ()
close) Bool
rightClick V2 -> Eff es a
child = do
  inp <- Eff es Input
forall (es :: [Effect]). (Ui :> es) => Eff es Input
askInput
  let mouse = Input -> V2
inputMousePos Input
inp
      pos = if Bool
rightClick then V2
mouse else V2
pos0
      cfg =
        PopupConfig
          { cfgAnchor :: PopupAnchor
cfgAnchor = V2 -> PopupAnchor
AnchorPoint V2
pos
          , cfgPlacement :: PopupPlacement
cfgPlacement = PopupPlacement
PlacementAtCursor
          , cfgDismissable :: Bool
cfgDismissable = Bool
True
          , cfgOffset :: Float
cfgOffset = Float
0
          }
  when rightClick (openAt mouse)
  (popupResp, mBody) <- popup (isOpen0 || rightClick) cfg (columnWith (tight . gap 0) (child pos))
  let picked = Response -> Bool
forall r. HasResponse r => r -> Bool
respHovered Response
popupResp Bool -> Bool -> Bool
&& Input -> Bool
inputMouseReleased Input
inp
  when (respClicked popupResp || picked) close
  pure mBody

-- | Open state for a context menu you position yourself: whether it is open,
-- where it was opened, an action to open it at a point, and one to close it.
useContextMenu ::
  Ui :> es =>
  Eff es (Bool, V2, V2 -> Eff es (), Eff es ())
useContextMenu :: forall (es :: [Effect]).
(Ui :> es) =>
Eff es (Bool, V2, V2 -> Eff es (), Eff es ())
useContextMenu = do
  wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
  ctx <- askContext
  let key = WidgetId -> Int
intKey WidgetId
wid
      openK = Slot -> Int -> Int
slotKey Slot
SlotMenuOpen Int
key
      posK = Slot -> Int -> Int
slotKey Slot
SlotMenuPos Int
key
  store <- uiIO (getStore ctx)
  let isOpen = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 Int
openK (WidgetStore -> IntMap Int
storeInt WidgetStore
store) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
      (px, py) = IM.findWithDefault (0, 0) posK (storePoint store)
      openAt (V2 Float
x Float
y) =
        IO () -> Eff es ()
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (IO () -> Eff es ()) -> IO () -> Eff es ()
forall a b. (a -> b) -> a -> b
$
          Context -> (WidgetStore -> WidgetStore) -> IO ()
modifyStore Context
ctx ((WidgetStore -> WidgetStore) -> IO ())
-> (WidgetStore -> WidgetStore) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WidgetStore
st ->
            WidgetStore
st
              { storeInt = IM.insert openK 1 (storeInt st)
              , storePoint = IM.insert posK (x, y) (storePoint st)
              }
      close = IO () -> Eff es ()
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (IO () -> Eff es ()) -> IO () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ Context -> (WidgetStore -> WidgetStore) -> IO ()
modifyStore Context
ctx ((WidgetStore -> WidgetStore) -> IO ())
-> (WidgetStore -> WidgetStore) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WidgetStore
st -> WidgetStore
st {storeInt = IM.delete openK (storeInt st)}
  pure (isOpen, V2 px py, openAt, close)

-- | One context-menu row; the whole row is the button.
data MenuItem = MenuItem
  { MenuItem -> Text
menuItemLabel :: !Text
  , MenuItem -> Maybe Text
menuItemHint :: !(Maybe Text)
    -- ^ Shortcut hint shown after the label, e.g. @Ctrl+S@.
  , MenuItem -> Bool
menuItemEnabled :: !Bool
    -- ^ Disabled rows are dimmed and cannot be clicked or focused.
  }
  deriving (MenuItem -> MenuItem -> Bool
(MenuItem -> MenuItem -> Bool)
-> (MenuItem -> MenuItem -> Bool) -> Eq MenuItem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MenuItem -> MenuItem -> Bool
== :: MenuItem -> MenuItem -> Bool
$c/= :: MenuItem -> MenuItem -> Bool
/= :: MenuItem -> MenuItem -> Bool
Eq, Int -> MenuItem -> ShowS
[MenuItem] -> ShowS
MenuItem -> String
(Int -> MenuItem -> ShowS)
-> (MenuItem -> String) -> ([MenuItem] -> ShowS) -> Show MenuItem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MenuItem -> ShowS
showsPrec :: Int -> MenuItem -> ShowS
$cshow :: MenuItem -> String
show :: MenuItem -> String
$cshowList :: [MenuItem] -> ShowS
showList :: [MenuItem] -> ShowS
Show)

-- | Render a menu row, returning its full 'Response'. A disabled row is a
-- muted label, not a disabled button: hover tracking does not know a button's
-- enabled flag and would still highlight it. Text nodes ignore padding, so the
-- label sits in a container that reproduces an enabled row's geometry: the
-- 'menuItemRowH' height and 'menuMinW' width, the label inset 'menuItemPadX'
-- plus the button's content inset, and the same total horizontal gutter the
-- solver reserves for menu buttons. Its response never reports interaction.
menuItemWith :: Ui :> es => MenuItem -> Eff es Response
menuItemWith :: forall (es :: [Effect]). (Ui :> es) => MenuItem -> Eff es Response
menuItemWith (MenuItem Text
lbl Maybe Text
hint Bool
enabled)
  | Bool
enabled = Text -> Float -> Layout -> Int -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
Text -> Float -> Layout -> Int -> Eff es Response
buttonStyled Text
text Float
0 Layout
menuRowLayout Int
buttonFlagMenu
  | Bool
otherwise = do
      ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
      let (ix, _) = widgetContentInset (ctxFontMetrics ctx)
          padLeft = Float
menuItemPadX Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ix
          padRight = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
menuOuterPad Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
menuItemPadX) Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
padLeft)
          rowLayout = (Float -> Layout -> Layout
minW Float
menuMinW Layout
defaultLayout) {layoutPadding = Padding padLeft padRight 0 0}
      (_, resp) <-
        containerResponse NodeContainer rowLayout $
          labelEx (fixedH menuItemRowH . tight . fontMuted $ defaultLayout) text
      pure
        resp
          { rawRespHovered = False
          , rawRespPressed = False
          , rawRespClicked = False
          , rawRespRightPressed = False
          , rawRespRightClicked = False
          }
  where
    text :: Text
text = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
lbl (\Text
s -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
lbl, Text
"  ", Text
s]) Maybe Text
hint

-- | Menu row. 'True' on the frame it is clicked.
--
-- @
-- whenM (menuItem "Open...") openFile
-- @
{-# INLINE menuItem #-}
menuItem :: Ui :> es => Text -> Eff es Bool
menuItem :: forall (es :: [Effect]). (Ui :> es) => Text -> Eff es Bool
menuItem Text
txt = Response -> Bool
forall r. HasResponse r => r -> Bool
respClicked (Response -> Bool) -> Eff es Response -> Eff es Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Eff es Response
forall (es :: [Effect]). (Ui :> es) => Text -> Eff es Response
menuItem' Text
txt

{-# INLINE menuItem' #-}
menuItem' :: Ui :> es => Text -> Eff es Response
menuItem' :: forall (es :: [Effect]). (Ui :> es) => Text -> Eff es Response
menuItem' Text
txt = MenuItem -> Eff es Response
forall (es :: [Effect]). (Ui :> es) => MenuItem -> Eff es Response
menuItemWith (Text -> Maybe Text -> Bool -> MenuItem
MenuItem Text
txt Maybe Text
forall a. Maybe a
Nothing Bool
True)

-- | Menu row with a shortcut hint after the label. The hint is only text;
-- handle the key itself elsewhere.
--
-- @
-- whenM (menuItemShortcut "Save" "Ctrl+S") saveFile
-- @
menuItemShortcut :: Ui :> es => Text -> Text -> Eff es Bool
menuItemShortcut :: forall (es :: [Effect]). (Ui :> es) => Text -> Text -> Eff es Bool
menuItemShortcut Text
txt Text
hint = Response -> Bool
forall r. HasResponse r => r -> Bool
respClicked (Response -> Bool) -> Eff es Response -> Eff es Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MenuItem -> Eff es Response
forall (es :: [Effect]). (Ui :> es) => MenuItem -> Eff es Response
menuItemWith (Text -> Maybe Text -> Bool -> MenuItem
MenuItem Text
txt (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
hint) Bool
True)

-- | Dimmed menu row that cannot be clicked.
menuItemDisabled :: Ui :> es => Text -> Eff es ()
menuItemDisabled :: forall (es :: [Effect]). (Ui :> es) => Text -> Eff es ()
menuItemDisabled Text
txt = Eff es Response -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MenuItem -> Eff es Response
forall (es :: [Effect]). (Ui :> es) => MenuItem -> Eff es Response
menuItemWith (Text -> Maybe Text -> Bool -> MenuItem
MenuItem Text
txt Maybe Text
forall a. Maybe a
Nothing Bool
False))

-- | Row layout shared by menu items, matching the text-field context menu:
-- 28px rows and a 148px minimum menu width (@menuItemRowH@ and @menuMinW@ in
-- @NanoUI.Font@).
menuRowLayout :: Layout
menuRowLayout :: Layout
menuRowLayout = Float -> Layout -> Layout
minW Float
menuMinW (Layout -> Layout) -> (Layout -> Layout) -> Layout -> Layout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Layout -> Layout
fixedH Float
menuItemRowH (Layout -> Layout) -> (Layout -> Layout) -> Layout -> Layout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> Layout
tight (Layout -> Layout) -> (Layout -> Layout) -> Layout -> Layout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> Layout
fillW (Layout -> Layout) -> Layout -> Layout
forall a b. (a -> b) -> a -> b
$ Layout
defaultLayout

-- | Menu-bar title: a flat, label-sized button. @open@ tints the title while
-- its drop-down is showing. 'True' on the frame it is clicked.
{-# INLINE menuButton #-}
menuButton :: Ui :> es => Text -> Bool -> Eff es Bool
menuButton :: forall (es :: [Effect]). (Ui :> es) => Text -> Bool -> Eff es Bool
menuButton Text
txt Bool
open = Response -> Bool
forall r. HasResponse r => r -> Bool
respClicked (Response -> Bool) -> Eff es Response -> Eff es Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Bool -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
Text -> Bool -> Eff es Response
menuButton' Text
txt Bool
open

-- | 'menuButton' returning its 'Response', whose rect anchors the drop-down.
menuButton' :: Ui :> es => Text -> Bool -> Eff es Response
menuButton' :: forall (es :: [Effect]).
(Ui :> es) =>
Text -> Bool -> Eff es Response
menuButton' Text
txt Bool
open =
  Text -> Float -> Layout -> Int -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
Text -> Float -> Layout -> Int -> Eff es Response
buttonStyled Text
txt (if Bool
open then Float
1 else Float
0) Layout
menuBarTitleLayout Int
buttonFlagMenuBar

menuBarTitleLayout :: Layout
menuBarTitleLayout :: Layout
menuBarTitleLayout = Layout -> Layout
tight (Layout -> Layout) -> Layout -> Layout
forall a b. (a -> b) -> a -> b
$ Layout
defaultLayout

-- | Separator line inside a context menu, matching the text-field context
-- menu painter exactly: a 1px rule inset 'menuItemPadX' from the panel edge
-- (the popup already contributes 'menuOuterPad', the row adds the remainder)
-- centered in a 'menuSepH' band (@lineY = bandY + h\/2@ via 4.5px vertical
-- padding around a zero-height content box). The rule sits in a 'tight'
-- column so it stays horizontal ('separator' adapts to its parent's
-- direction and would grow vertically inside the padded row) and so the
-- default 3px container padding does not inset or stretch it.
menuSeparator :: Ui :> es => Eff es ()
menuSeparator :: forall (es :: [Effect]). (Ui :> es) => Eff es ()
menuSeparator = do
  (Layout -> Layout) -> Eff es () -> Eff es ()
forall (es :: [Effect]) a.
(Ui :> es) =>
(Layout -> Layout) -> Eff es a -> Eff es a
rowWith (Float -> Layout -> Layout
fixedH Float
menuSepH (Layout -> Layout) -> (Layout -> Layout) -> Layout -> Layout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Layout -> Layout
padXY (Float
menuItemPadX Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
menuOuterPad) Float
4.5 (Layout -> Layout) -> (Layout -> Layout) -> Layout -> Layout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> Layout
fillW) (Eff es () -> Eff es ()) -> Eff es () -> Eff es ()
forall a b. (a -> b) -> a -> b
$
    (Layout -> Layout) -> Eff es () -> Eff es ()
forall (es :: [Effect]) a.
(Ui :> es) =>
(Layout -> Layout) -> Eff es a -> Eff es a
columnWith (Layout -> Layout
tight (Layout -> Layout) -> (Layout -> Layout) -> Layout -> Layout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> Layout
fillW) Eff es ()
forall (es :: [Effect]). (Ui :> es) => Eff es ()
separator

-- | Header / category title inside a context menu.
menuHeader :: Ui :> es => Text -> Eff es ()
menuHeader :: forall (es :: [Effect]). (Ui :> es) => Text -> Eff es ()
menuHeader Text
txt =
  Eff es Response -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Layout -> Text -> Eff es Response
forall (es :: [Effect]).
(Ui :> es) =>
Layout -> Text -> Eff es Response
labelEx (Float -> Float -> Layout -> Layout
padXY Float
6 Float
2 Layout
defaultLayout) Text
txt)