{-# LANGUAGE OverloadedStrings #-}

module NanoUI.Widgets.Popup
  ( PopupAnchor (..)
  , PopupPlacement (..)
  , PopupConfig (..)
  , defaultPopupConfig
  , popup
  , popupWith
  , floatingOverlay
  , tooltipWidget
  , tooltipAt
  , tooltip
  , withTooltip
  )
where

import Control.Monad (void)
import Data.IORef (modifyIORef')
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Effectful (Eff, type (:>))
import NanoUI.Context
  ( Context (..)
  , getPrevRect
  , registerPopupConfig
  , seedFloatingPanel
  )
import NanoUI.Id (WidgetId, enterScope, scopeTag)
import NanoUI.Input (inputMousePos)
import NanoUI.Layout.Arena (NodeIdx, NodeType (..), addNode)
import NanoUI.Monad
  ( Ui
  , askContext
  , askDefaultLayout
  , askInput
  , nextId
  , uiIO
  )
import NanoUI.Style
  ( AlignX (..)
  , AlignY (..)
  , Layout (..)
  , Padding (..)
  , defaultLayout
  , tight
  )
import NanoUI.Types
  ( PopupAnchor (..)
  , PopupPlacement (..)
  , Rect (..)
  , rectHit
  , rectNonEmpty
  )
import NanoUI.Widgets.Behavior (useDismissable)
import NanoUI.Widgets.Layout (label)
import NanoUI.Widgets.Node
  ( HasResponse
  , Response (..)
  , containerResponse
  , emptyModalResp
  , floatingPanel
  , mkResponse
  , respHovered
  , respRect
  )

data PopupConfig = PopupConfig
  { PopupConfig -> PopupAnchor
cfgAnchor :: !PopupAnchor
  , PopupConfig -> PopupPlacement
cfgPlacement :: !PopupPlacement
  , PopupConfig -> Bool
cfgDismissable :: !Bool
  , PopupConfig -> Float
cfgOffset :: !Float
  }
  deriving (PopupConfig -> PopupConfig -> Bool
(PopupConfig -> PopupConfig -> Bool)
-> (PopupConfig -> PopupConfig -> Bool) -> Eq PopupConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PopupConfig -> PopupConfig -> Bool
== :: PopupConfig -> PopupConfig -> Bool
$c/= :: PopupConfig -> PopupConfig -> Bool
/= :: PopupConfig -> PopupConfig -> Bool
Eq, Int -> PopupConfig -> ShowS
[PopupConfig] -> ShowS
PopupConfig -> String
(Int -> PopupConfig -> ShowS)
-> (PopupConfig -> String)
-> ([PopupConfig] -> ShowS)
-> Show PopupConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PopupConfig -> ShowS
showsPrec :: Int -> PopupConfig -> ShowS
$cshow :: PopupConfig -> String
show :: PopupConfig -> String
$cshowList :: [PopupConfig] -> ShowS
showList :: [PopupConfig] -> ShowS
Show)

defaultPopupConfig :: PopupAnchor -> PopupConfig
defaultPopupConfig :: PopupAnchor -> PopupConfig
defaultPopupConfig PopupAnchor
anchor =
  PopupConfig
    { cfgAnchor :: PopupAnchor
cfgAnchor = PopupAnchor
anchor
    , cfgPlacement :: PopupPlacement
cfgPlacement = PopupPlacement
PlacementAuto
    , cfgDismissable :: Bool
cfgDismissable = Bool
True
    , cfgOffset :: Float
cfgOffset = Float
4
    }

-- | A floating panel placed by the config, shown while @open@. Returns the
-- body's result while open. The 'Response' reports a dismissal (Escape, or a
-- click outside when 'cfgDismissable') as a click.
popup ::
  Ui :> es =>
  Bool ->
  PopupConfig ->
  Eff es a ->
  Eff es (Response, Maybe a)
popup :: forall (es :: [Effect]) a.
(Ui :> es) =>
Bool -> PopupConfig -> Eff es a -> Eff es (Response, Maybe a)
popup Bool
open PopupConfig
cfg Eff es a
child = Bool
-> PopupConfig
-> (Layout -> Layout)
-> Eff es a
-> Eff es (Response, Maybe a)
forall (es :: [Effect]) a.
(Ui :> es) =>
Bool
-> PopupConfig
-> (Layout -> Layout)
-> Eff es a
-> Eff es (Response, Maybe a)
popupWith Bool
open PopupConfig
cfg Layout -> Layout
forall a. a -> a
id Eff es a
child

-- | 'popup' with a modifier applied to its tight default layout.
popupWith ::
  Ui :> es =>
  Bool ->
  PopupConfig ->
  (Layout -> Layout) ->
  Eff es a ->
  Eff es (Response, Maybe a)
popupWith :: forall (es :: [Effect]) a.
(Ui :> es) =>
Bool
-> PopupConfig
-> (Layout -> Layout)
-> Eff es a
-> Eff es (Response, Maybe a)
popupWith Bool
open PopupConfig
cfg Layout -> Layout
f Eff es a
child = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  let
    layout = Layout -> Layout
f (Layout -> Layout
tight Layout
defaultLayout)
    addPopupNode WidgetId
wid Int
parent = do
      Context
-> WidgetId -> PopupAnchor -> PopupPlacement -> Float -> IO ()
registerPopupConfig Context
ctx WidgetId
wid (PopupConfig -> PopupAnchor
cfgAnchor PopupConfig
cfg) (PopupConfig -> PopupPlacement
cfgPlacement PopupConfig
cfg) (PopupConfig -> Float
cfgOffset PopupConfig
cfg)
      NodeArena
-> NodeType
-> Int
-> Direction
-> Sizing
-> Sizing
-> Padding
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> AlignX
-> AlignY
-> IO Int
addNode
        (Context -> NodeArena
ctxNodeArena Context
ctx)
        NodeType
NodePopup
        Int
parent
        (Layout -> Direction
layoutDirection Layout
layout)
        (Layout -> Sizing
layoutWidth Layout
layout)
        (Layout -> Sizing
layoutHeight Layout
layout)
        (Float -> Float -> Float -> Float -> Padding
Padding Float
6 Float
6 Float
6 Float
6)
        Float
4
        Float
0
        Float
0
        Float
1e9
        Float
1e9
        Float
0
        AlignX
AlignStart
        AlignY
AlignTop
    seedFromPrev WidgetId
wid = Context -> WidgetId -> IO (Maybe Rect)
getPrevRect Context
ctx WidgetId
wid IO (Maybe Rect) -> (Maybe Rect -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rect -> IO ()) -> Maybe Rect -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Context -> WidgetId -> Rect -> IO ()
seedFloatingPanel Context
ctx WidgetId
wid)
  floatingOverlay open (cfgDismissable cfg) addPopupNode seedFromPrev ((,) False <$> child)

-- | The floating panel behind popups, modals and windows, shown while @open@
-- with its body in its own id scope. @addPanel@ and @enter@ are those of
-- 'floatingPanel', given the panel's id. The body returns whether it closed
-- the panel along with its result. The 'Response' reports a dismissal (the
-- body's close, Escape, or a click outside when @dismissable@) as a click. A
-- closed panel still consumes its id scope, so the ids of later siblings do
-- not shift when it opens.
floatingOverlay ::
  Ui :> es =>
  Bool ->
  Bool ->
  (WidgetId -> Int -> IO NodeIdx) ->
  (WidgetId -> IO ()) ->
  Eff es (Bool, a) ->
  Eff es (Response, Maybe a)
floatingOverlay :: forall (es :: [Effect]) a.
(Ui :> es) =>
Bool
-> Bool
-> (WidgetId -> Int -> IO Int)
-> (WidgetId -> IO ())
-> Eff es (Bool, a)
-> Eff es (Response, Maybe a)
floatingOverlay Bool
open Bool
dismissable WidgetId -> Int -> IO Int
addPanel WidgetId -> IO ()
enter Eff es (Bool, a)
body = do
  wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
  ctx <- askContext
  if not open
    then do
      uiIO (modifyIORef' (ctxIdContext ctx) (fst . enterScope scopeTag))
      pure (emptyModalResp wid, Nothing)
    else do
      inp <- askInput
      (closed, r) <- floatingPanel True wid (addPanel wid) (enter wid) body
      panel <- fromMaybe (Rect 0 0 0 0) <$> uiIO (getPrevRect ctx wid)
      outside <-
        if dismissable && rectNonEmpty panel
          then useDismissable panel
          else pure False
      let dismissed = Bool
closed Bool -> Bool -> Bool
|| Bool
outside
      pure
        ( mkResponse wid panel (rectHit panel (inputMousePos inp)) False dismissed dismissed
        , Just r
        )

-- | Attach a rich tooltip widget to any target response, displayed on hover.
tooltipWidget ::
  (Ui :> es, HasResponse r) =>
  r ->
  Eff es a ->
  Eff es (Maybe a)
tooltipWidget :: forall (es :: [Effect]) r a.
(Ui :> es, HasResponse r) =>
r -> Eff es a -> Eff es (Maybe a)
tooltipWidget r
target Eff es a
child =
  (Response, Maybe a) -> Maybe a
forall a b. (a, b) -> b
snd ((Response, Maybe a) -> Maybe a)
-> Eff es (Response, Maybe a) -> Eff es (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> PopupConfig -> Eff es a -> Eff es (Response, Maybe a)
forall (es :: [Effect]) a.
(Ui :> es) =>
Bool -> PopupConfig -> Eff es a -> Eff es (Response, Maybe a)
popup (r -> Bool
forall r. HasResponse r => r -> Bool
respHovered r
target) PopupConfig
cfg Eff es a
child
  where
    cfg :: PopupConfig
cfg = (PopupAnchor -> PopupConfig
defaultPopupConfig (Rect -> PopupAnchor
AnchorRect (r -> Rect
forall r. HasResponse r => r -> Rect
respRect r
target))) {cfgPlacement = PlacementBelow, cfgDismissable = False}

-- | Attach a rich tooltip widget to an inner UI computation.
withTooltip ::
  Ui :> es =>
  Eff es a ->
  Eff es b ->
  Eff es (a, Maybe b)
withTooltip :: forall (es :: [Effect]) a b.
(Ui :> es) =>
Eff es a -> Eff es b -> Eff es (a, Maybe b)
withTooltip Eff es a
mainChild Eff es b
tipChild = do
  base <- Eff es Layout
forall (es :: [Effect]). (Ui :> es) => Eff es Layout
askDefaultLayout
  (res, contResp) <- containerResponse NodeContainer (tight base) mainChild
  mTip <- tooltipWidget contResp tipChild
  pure (res, mTip)

-- | 'tooltip' with a placement.
tooltipAt ::
  (Ui :> es, HasResponse r) =>
  PopupPlacement ->
  r ->
  Text ->
  Eff es ()
tooltipAt :: forall (es :: [Effect]) r.
(Ui :> es, HasResponse r) =>
PopupPlacement -> r -> Text -> Eff es ()
tooltipAt PopupPlacement
placement r
target Text
txt =
  Eff es (Response, Maybe ()) -> Eff es ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Bool -> PopupConfig -> Eff es () -> Eff es (Response, Maybe ())
forall (es :: [Effect]) a.
(Ui :> es) =>
Bool -> PopupConfig -> Eff es a -> Eff es (Response, Maybe a)
popup (r -> Bool
forall r. HasResponse r => r -> Bool
respHovered r
target) PopupConfig
cfg (Text -> Eff es ()
forall (es :: [Effect]). (Ui :> es) => Text -> Eff es ()
label Text
txt))
  where
    cfg :: PopupConfig
cfg = (PopupAnchor -> PopupConfig
defaultPopupConfig (Rect -> PopupAnchor
AnchorRect (r -> Rect
forall r. HasResponse r => r -> Rect
respRect r
target))) {cfgPlacement = placement, cfgDismissable = False}

-- | Text shown below a widget while the pointer is over it.
--
-- @
-- save <- button' "Save"
-- tooltip save "Write the file to disk"
-- @
tooltip ::
  (Ui :> es, HasResponse r) =>
  r ->
  Text ->
  Eff es ()
tooltip :: forall (es :: [Effect]) r.
(Ui :> es, HasResponse r) =>
r -> Text -> Eff es ()
tooltip = PopupPlacement -> r -> Text -> Eff es ()
forall (es :: [Effect]) r.
(Ui :> es, HasResponse r) =>
PopupPlacement -> r -> Text -> Eff es ()
tooltipAt PopupPlacement
PlacementBelow