{-|
Module      : Monomer.Widgets.Containers.Popup
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Popup widget, used to display content overlaid on top of the active widget tree.
When the popup is open, events will not reach the widgets below it.

In addition to the content that is displayed when open, a popup requires a
boolean lens or value to indicate if the content should be visible. This flag
can be used to programatically open/close the popup. The popup can also be
closed by clicking outside its content.

In general, it is a good idea to set a background color to the top level content
widget, since by default most widgets have a transparent background; this is
true in particular for containers.

@
popup visiblePopup $  -- visiblePopup is a lens to a Bool field in the model
  label "This will appear on top of the widget tree"
    `styleBasic` [bgColor gray, padding 10]
@

By default the popup will be open at the top-left location the widget would be
if it was directly embedded in the widget tree. One common pattern is having a
popup open when clicking a button, and the expectation is it will open below the
button. This can be achieved with:

@
vstack [
  button "Open" OpenPopup,
  popup visiblePopup (label "Content")
]
@

The popup's content can be aligned relative to the location of the popup widget
in the widget tree:

@
popup_ visiblePopup [alignTop, alignCenter] $
  label "This will appear on top of the widget tree, aligned to the top-center"
    `styleBasic` [bgColor gray, padding 10]
@

Alternatively, aligning relative to the application's window is possible. This
can be useful for displaying notifications:

@
popup_ visiblePopup [popupAlignToWindow, alignTop, alignCenter] $
  label "This will appear centered at the top of the main window"
    `styleBasic` [bgColor gray, padding 10]
@

It's possible to add an offset to the location of the popup, and also combine it
with alignment options:

@
cfgs = [popupAlignToWindow, alignTop, alignCenter, popupOffset (Point 0 5)]

popup_ visiblePopup cfgs $
  label "This will appear centered almost at the top of the main window"
    `styleBasic` [bgColor gray, padding 10]
@

Alternatively, a widget can be provided as an anchor. This is not too different
than the previous examples but opens up more alignment options, since the
popup's content can now be aligned relative to the outer side of the edges of
the anchor widget.

@
anchor = toggleButton "Show popup" visiblePopup
cfgs = [popupAnchor anchor, popupAlignToOuterV, alignTop, alignCenter]

popup_ visiblePopup cfgs $
  label "The bottom of the content will be aligned to the top of the anchor"
    `styleBasic` [bgColor gray, padding 10]
@

For an example of popup's use, check 'Monomer.Widgets.Singles.ColorPopup'.

Note: style settings will be ignored by this widget. The content and anchor need
to be styled independently.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}

module Monomer.Widgets.Containers.Popup (
  -- * Configuration
  PopupCfg,
  popupAnchor,
  popupAlignToOuterH,
  popupAlignToOuterH_,
  popupAlignToOuterV,
  popupAlignToOuterV_,
  popupAlignToWindow,
  popupAlignToWindow_,
  popupOffset,
  popupOpenAtCursor,
  popupOpenAtCursor_,
  popupDisableClose,
  popupDisableClose_,

  -- * Constructors
  popup,
  popup_,
  popupV,
  popupV_,
  popupD_
) where

import Control.Applicative ((<|>))
import Control.Lens -- ((&), (^.), (^?!), (.~), ALens', ix)
import Control.Monad (when)
import Data.Default
import Data.Maybe

import qualified Data.Sequence as Seq

import Monomer.Widgets.Container
import Monomer.Widgets.Singles.Spacer

import qualified Monomer.Lens as L

{-|
Configuration options for popup:

- 'popupAnchor': a widget to be used as a reference for positioning the popup.
- 'popupAlignToOuter': align the popup to the anchor's outer borders.
- 'popupAlignToWindow': align the popup to the application's window.
- 'popupOffset': offset to add to the default location of the popup.
- 'popupOpenAtCursor': whether to open the content at the cursor position.
- 'popupDisableClose': do not close the popup when clicking outside the content.
- 'alignLeft': left align relative to the widget location or main window.
- 'alignRight': right align relative to the widget location or main window.
- 'alignCenter': center align relative to the widget location or main window.
- 'alignTop': top align relative to the widget location or main window.
- 'alignMiddle': middle align relative to the widget location or main window.
- 'alignBottom': bottom align relative to the widget location or main window.
- 'onChange': event to raise when the popup is opened/closed.
- 'onChangeReq': 'WidgetRequest' to generate when the popup is opened/closed.
-}
data PopupCfg s e = PopupCfg {
  forall s e. PopupCfg s e -> Maybe (WidgetNode s e)
_ppcAnchor :: Maybe (WidgetNode s e),
  forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToOuterH :: Maybe Bool,
  forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToOuterV :: Maybe Bool,
  forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToWindow :: Maybe Bool,
  forall s e. PopupCfg s e -> Maybe AlignH
_ppcAlignH :: Maybe AlignH,
  forall s e. PopupCfg s e -> Maybe AlignV
_ppcAlignV :: Maybe AlignV,
  forall s e. PopupCfg s e -> Maybe Point
_ppcOffset :: Maybe Point,
  forall s e. PopupCfg s e -> Maybe Bool
_ppcOpenAtCursor :: Maybe Bool,
  forall s e. PopupCfg s e -> Maybe Bool
_ppcDisableClose :: Maybe Bool,
  forall s e. PopupCfg s e -> [Bool -> WidgetRequest s e]
_ppcOnChangeReq :: [Bool -> WidgetRequest s e]
}

instance Default (PopupCfg s e) where
  def :: PopupCfg s e
def = PopupCfg {
    _ppcAnchor :: Maybe (WidgetNode s e)
_ppcAnchor = forall a. Maybe a
Nothing,
    _ppcAlignToOuterH :: Maybe Bool
_ppcAlignToOuterH = forall a. Maybe a
Nothing,
    _ppcAlignToOuterV :: Maybe Bool
_ppcAlignToOuterV = forall a. Maybe a
Nothing,
    _ppcAlignToWindow :: Maybe Bool
_ppcAlignToWindow = forall a. Maybe a
Nothing,
    _ppcAlignH :: Maybe AlignH
_ppcAlignH = forall a. Maybe a
Nothing,
    _ppcAlignV :: Maybe AlignV
_ppcAlignV = forall a. Maybe a
Nothing,
    _ppcOffset :: Maybe Point
_ppcOffset = forall a. Maybe a
Nothing,
    _ppcOpenAtCursor :: Maybe Bool
_ppcOpenAtCursor = forall a. Maybe a
Nothing,
    _ppcDisableClose :: Maybe Bool
_ppcDisableClose = forall a. Maybe a
Nothing,
    _ppcOnChangeReq :: [Bool -> WidgetRequest s e]
_ppcOnChangeReq = []
  }

instance Semigroup (PopupCfg s e) where
  <> :: PopupCfg s e -> PopupCfg s e -> PopupCfg s e
(<>) PopupCfg s e
t1 PopupCfg s e
t2 = PopupCfg {
    _ppcAnchor :: Maybe (WidgetNode s e)
_ppcAnchor = forall s e. PopupCfg s e -> Maybe (WidgetNode s e)
_ppcAnchor PopupCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. PopupCfg s e -> Maybe (WidgetNode s e)
_ppcAnchor PopupCfg s e
t1,
    _ppcAlignToOuterH :: Maybe Bool
_ppcAlignToOuterH = forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToOuterH PopupCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToOuterH PopupCfg s e
t1,
    _ppcAlignToOuterV :: Maybe Bool
_ppcAlignToOuterV = forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToOuterV PopupCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToOuterV PopupCfg s e
t1,
    _ppcAlignToWindow :: Maybe Bool
_ppcAlignToWindow = forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToWindow PopupCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToWindow PopupCfg s e
t1,
    _ppcAlignH :: Maybe AlignH
_ppcAlignH = forall s e. PopupCfg s e -> Maybe AlignH
_ppcAlignH PopupCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. PopupCfg s e -> Maybe AlignH
_ppcAlignH PopupCfg s e
t1,
    _ppcAlignV :: Maybe AlignV
_ppcAlignV = forall s e. PopupCfg s e -> Maybe AlignV
_ppcAlignV PopupCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. PopupCfg s e -> Maybe AlignV
_ppcAlignV PopupCfg s e
t1,
    _ppcOffset :: Maybe Point
_ppcOffset = forall s e. PopupCfg s e -> Maybe Point
_ppcOffset PopupCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. PopupCfg s e -> Maybe Point
_ppcOffset PopupCfg s e
t1,
    _ppcOpenAtCursor :: Maybe Bool
_ppcOpenAtCursor = forall s e. PopupCfg s e -> Maybe Bool
_ppcOpenAtCursor PopupCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. PopupCfg s e -> Maybe Bool
_ppcOpenAtCursor PopupCfg s e
t1,
    _ppcDisableClose :: Maybe Bool
_ppcDisableClose = forall s e. PopupCfg s e -> Maybe Bool
_ppcDisableClose PopupCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. PopupCfg s e -> Maybe Bool
_ppcDisableClose PopupCfg s e
t1,
    _ppcOnChangeReq :: [Bool -> WidgetRequest s e]
_ppcOnChangeReq = forall s e. PopupCfg s e -> [Bool -> WidgetRequest s e]
_ppcOnChangeReq PopupCfg s e
t1 forall a. Semigroup a => a -> a -> a
<> forall s e. PopupCfg s e -> [Bool -> WidgetRequest s e]
_ppcOnChangeReq PopupCfg s e
t2
  }

instance Monoid (PopupCfg s e) where
  mempty :: PopupCfg s e
mempty = forall a. Default a => a
def

instance CmbAlignLeft (PopupCfg s e) where
  alignLeft_ :: Bool -> PopupCfg s e
alignLeft_ Bool
False = forall a. Default a => a
def
  alignLeft_ Bool
True = forall a. Default a => a
def {
    _ppcAlignH :: Maybe AlignH
_ppcAlignH = forall a. a -> Maybe a
Just AlignH
ALeft
  }

instance CmbAlignCenter (PopupCfg s e) where
  alignCenter_ :: Bool -> PopupCfg s e
alignCenter_ Bool
False = forall a. Default a => a
def
  alignCenter_ Bool
True = forall a. Default a => a
def {
    _ppcAlignH :: Maybe AlignH
_ppcAlignH = forall a. a -> Maybe a
Just AlignH
ACenter
  }

instance CmbAlignRight (PopupCfg s e) where
  alignRight_ :: Bool -> PopupCfg s e
alignRight_ Bool
False = forall a. Default a => a
def
  alignRight_ Bool
True = forall a. Default a => a
def {
    _ppcAlignH :: Maybe AlignH
_ppcAlignH = forall a. a -> Maybe a
Just AlignH
ARight
  }

instance CmbAlignTop (PopupCfg s e) where
  alignTop_ :: Bool -> PopupCfg s e
alignTop_ Bool
False = forall a. Default a => a
def
  alignTop_ Bool
True = forall a. Default a => a
def {
    _ppcAlignV :: Maybe AlignV
_ppcAlignV = forall a. a -> Maybe a
Just AlignV
ATop
  }

instance CmbAlignMiddle (PopupCfg s e) where
  alignMiddle_ :: Bool -> PopupCfg s e
alignMiddle_ Bool
False = forall a. Default a => a
def
  alignMiddle_ Bool
True = forall a. Default a => a
def {
    _ppcAlignV :: Maybe AlignV
_ppcAlignV = forall a. a -> Maybe a
Just AlignV
AMiddle
  }

instance CmbAlignBottom (PopupCfg s e) where
  alignBottom_ :: Bool -> PopupCfg s e
alignBottom_ Bool
False = forall a. Default a => a
def
  alignBottom_ Bool
True = forall a. Default a => a
def {
    _ppcAlignV :: Maybe AlignV
_ppcAlignV = forall a. a -> Maybe a
Just AlignV
ABottom
  }

instance WidgetEvent e => CmbOnChange (PopupCfg s e) Bool e where
  onChange :: (Bool -> e) -> PopupCfg s e
onChange Bool -> e
fn = forall a. Default a => a
def {
    _ppcOnChangeReq :: [Bool -> WidgetRequest s e]
_ppcOnChangeReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> e
fn]
  }

instance CmbOnChangeReq (PopupCfg s e) s e Bool where
  onChangeReq :: (Bool -> WidgetRequest s e) -> PopupCfg s e
onChangeReq Bool -> WidgetRequest s e
req = forall a. Default a => a
def {
    _ppcOnChangeReq :: [Bool -> WidgetRequest s e]
_ppcOnChangeReq = [Bool -> WidgetRequest s e
req]
  }

{-|
Sets the widget that will be used as the anchor for the popup. In general, this
anchor will also act as the trigger to open the popup (e.g. a button). When the
popup is open, the anchor will be used to position the content, taking scroll
and window size into consideration.
-}
popupAnchor :: WidgetNode s e -> PopupCfg s e
popupAnchor :: forall s e. WidgetNode s e -> PopupCfg s e
popupAnchor WidgetNode s e
node = forall a. Default a => a
def {
  _ppcAnchor :: Maybe (WidgetNode s e)
_ppcAnchor = forall a. a -> Maybe a
Just WidgetNode s e
node
}

{-
Align the popup to the horizontal outer edges of the anchor. It only works with
'alignLeft' and 'alignRight', which need to be specified separately.

This option only works when 'popupAnchor' is set.
-}
popupAlignToOuterH :: PopupCfg s e
popupAlignToOuterH :: forall s e. PopupCfg s e
popupAlignToOuterH = forall s e. Bool -> PopupCfg s e
popupAlignToOuterH_ Bool
True

{-|
Sets whether to align the popup to the horizontal outer edges of the anchor. It
only works with 'alignLeft' and 'alignRight', which need to be specified
separately.

This option only works when 'popupAnchor' is set.
-}
popupAlignToOuterH_ :: Bool -> PopupCfg s e
popupAlignToOuterH_ :: forall s e. Bool -> PopupCfg s e
popupAlignToOuterH_ Bool
align = forall a. Default a => a
def {
  _ppcAlignToOuterH :: Maybe Bool
_ppcAlignToOuterH = forall a. a -> Maybe a
Just Bool
align
}

{-
Align the popup vertically to the outer edges of the anchor. It only works with
'alignTop' and 'alignBottom', which need to be specified separately.

This option only works when 'popupAnchor' is set.
-}
popupAlignToOuterV :: PopupCfg s e
popupAlignToOuterV :: forall s e. PopupCfg s e
popupAlignToOuterV = forall s e. Bool -> PopupCfg s e
popupAlignToOuterV_ Bool
True

{-|
Sets whether to align the popup vertically to the outer edges of the anchor. It
only works with 'alignTop' and 'alignBottom', which need to be specified
separately.

This option only works when 'popupAnchor' is set.
-}
popupAlignToOuterV_ :: Bool -> PopupCfg s e
popupAlignToOuterV_ :: forall s e. Bool -> PopupCfg s e
popupAlignToOuterV_ Bool
align = forall a. Default a => a
def {
  _ppcAlignToOuterV :: Maybe Bool
_ppcAlignToOuterV = forall a. a -> Maybe a
Just Bool
align
}

-- | Alignment will be relative to the application's main window.
popupAlignToWindow :: PopupCfg s e
popupAlignToWindow :: forall s e. PopupCfg s e
popupAlignToWindow = forall s e. Bool -> PopupCfg s e
popupAlignToWindow_ Bool
True

-- | Sets whether alignment will be relative to the application's main window.
popupAlignToWindow_ :: Bool -> PopupCfg s e
popupAlignToWindow_ :: forall s e. Bool -> PopupCfg s e
popupAlignToWindow_ Bool
align = forall a. Default a => a
def {
  _ppcAlignToWindow :: Maybe Bool
_ppcAlignToWindow = forall a. a -> Maybe a
Just Bool
align
}

{-|
Offset to be applied to the location of the popup. It is applied after alignment
options but before adjusting for screen boundaries.
-}
popupOffset :: Point -> PopupCfg s e
popupOffset :: forall s e. Point -> PopupCfg s e
popupOffset Point
point = forall a. Default a => a
def {
  _ppcOffset :: Maybe Point
_ppcOffset = forall a. a -> Maybe a
Just Point
point
}

-- | The popup will open at the current cursor position.
popupOpenAtCursor :: PopupCfg s e
popupOpenAtCursor :: forall s e. PopupCfg s e
popupOpenAtCursor = forall s e. Bool -> PopupCfg s e
popupOpenAtCursor_ Bool
True

-- | Sets whether the popup will open at the current cursor position.
popupOpenAtCursor_ :: Bool -> PopupCfg s e
popupOpenAtCursor_ :: forall s e. Bool -> PopupCfg s e
popupOpenAtCursor_ Bool
open = forall a. Default a => a
def {
  _ppcOpenAtCursor :: Maybe Bool
_ppcOpenAtCursor = forall a. a -> Maybe a
Just Bool
open
}

-- | Clicking outside the popup's content will not close it.
popupDisableClose :: PopupCfg s e
popupDisableClose :: forall s e. PopupCfg s e
popupDisableClose = forall s e. Bool -> PopupCfg s e
popupDisableClose_ Bool
True

-- | Sets whether clicking outside the popup's content will not close it.
popupDisableClose_ :: Bool -> PopupCfg s e
popupDisableClose_ :: forall s e. Bool -> PopupCfg s e
popupDisableClose_ Bool
close = forall a. Default a => a
def {
  _ppcDisableClose :: Maybe Bool
_ppcDisableClose = forall a. a -> Maybe a
Just Bool
close
}

data PopupState = PopupState {
  PopupState -> Point
_ppsClickPos :: Point,
  PopupState -> Millisecond
_ppsReleaseMs :: Millisecond
} deriving (PopupState -> PopupState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PopupState -> PopupState -> Bool
$c/= :: PopupState -> PopupState -> Bool
== :: PopupState -> PopupState -> Bool
$c== :: PopupState -> PopupState -> Bool
Eq, Int -> PopupState -> ShowS
[PopupState] -> ShowS
PopupState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PopupState] -> ShowS
$cshowList :: [PopupState] -> ShowS
show :: PopupState -> String
$cshow :: PopupState -> String
showsPrec :: Int -> PopupState -> ShowS
$cshowsPrec :: Int -> PopupState -> ShowS
Show)

-- | Creates a popup with the given lens to determine its visibility.
popup
  :: WidgetModel s
  => ALens' s Bool
  -> WidgetNode s e
  -> WidgetNode s e
popup :: forall s e.
WidgetModel s =>
ALens' s Bool -> WidgetNode s e -> WidgetNode s e
popup ALens' s Bool
field WidgetNode s e
content = forall s e.
WidgetModel s =>
ALens' s Bool -> [PopupCfg s e] -> WidgetNode s e -> WidgetNode s e
popup_ ALens' s Bool
field forall a. Default a => a
def WidgetNode s e
content

{-|
Creates a popup with the given lens to determine its visibility. Accepts config.
-}
popup_
  :: WidgetModel s
  => ALens' s Bool
  -> [PopupCfg s e]
  -> WidgetNode s e
  -> WidgetNode s e
popup_ :: forall s e.
WidgetModel s =>
ALens' s Bool -> [PopupCfg s e] -> WidgetNode s e -> WidgetNode s e
popup_ ALens' s Bool
field [PopupCfg s e]
configs WidgetNode s e
content = WidgetNode s e
newNode where
  newNode :: WidgetNode s e
newNode = forall s e.
WidgetModel s =>
WidgetData s Bool
-> [PopupCfg s e] -> WidgetNode s e -> WidgetNode s e
popupD_ (forall s a. ALens' s a -> WidgetData s a
WidgetLens ALens' s Bool
field) [PopupCfg s e]
configs WidgetNode s e
content

{-|
Creates a popup using the given value to determine its visibility and 'onChange'
event handler.
-}
popupV
  :: (WidgetModel s, WidgetEvent e)
  => Bool
  -> (Bool -> e)
  -> WidgetNode s e
  -> WidgetNode s e
popupV :: forall s e.
(WidgetModel s, WidgetEvent e) =>
Bool -> (Bool -> e) -> WidgetNode s e -> WidgetNode s e
popupV Bool
value Bool -> e
handler WidgetNode s e
content = forall s e.
(WidgetModel s, WidgetEvent e) =>
Bool
-> (Bool -> e)
-> [PopupCfg s e]
-> WidgetNode s e
-> WidgetNode s e
popupV_ Bool
value Bool -> e
handler forall a. Default a => a
def WidgetNode s e
content

{-|
Creates a popup using the given value to determine its visibility and 'onChange'
event handler. Accepts config.
-}
popupV_
  :: (WidgetModel s, WidgetEvent e)
  => Bool
  -> (Bool -> e)
  -> [PopupCfg s e]
  -> WidgetNode s e
  -> WidgetNode s e
popupV_ :: forall s e.
(WidgetModel s, WidgetEvent e) =>
Bool
-> (Bool -> e)
-> [PopupCfg s e]
-> WidgetNode s e
-> WidgetNode s e
popupV_ Bool
value Bool -> e
handler [PopupCfg s e]
configs WidgetNode s e
content = WidgetNode s e
newNode where
  newConfigs :: [PopupCfg s e]
newConfigs = forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange Bool -> e
handler forall a. a -> [a] -> [a]
: [PopupCfg s e]
configs
  newNode :: WidgetNode s e
newNode = forall s e.
WidgetModel s =>
WidgetData s Bool
-> [PopupCfg s e] -> WidgetNode s e -> WidgetNode s e
popupD_ (forall s a. a -> WidgetData s a
WidgetValue Bool
value) [PopupCfg s e]
newConfigs WidgetNode s e
content

{-|
Creates a popup providing a 'WidgetData' instance to determine its visibility
and config.
-}
popupD_
  :: WidgetModel s
  => WidgetData s Bool
  -> [PopupCfg s e]
  -> WidgetNode s e
  -> WidgetNode s e
popupD_ :: forall s e.
WidgetModel s =>
WidgetData s Bool
-> [PopupCfg s e] -> WidgetNode s e -> WidgetNode s e
popupD_ WidgetData s Bool
wdata [PopupCfg s e]
configs WidgetNode s e
content = forall s e.
Widget s e -> WidgetNode s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
widget WidgetNode s e
anchor WidgetNode s e
content where
  config :: PopupCfg s e
config = forall a. Monoid a => [a] -> a
mconcat [PopupCfg s e]
configs
  state :: PopupState
state = Point -> Millisecond -> PopupState
PopupState forall a. Default a => a
def (-Millisecond
1)
  widget :: Widget s e
widget = forall s e.
WidgetModel s =>
WidgetData s Bool -> PopupCfg s e -> PopupState -> Widget s e
makePopup WidgetData s Bool
wdata PopupCfg s e
config PopupState
state

  anchor :: WidgetNode s e
anchor = case forall s e. PopupCfg s e -> Maybe (WidgetNode s e)
_ppcAnchor PopupCfg s e
config of
    Just WidgetNode s e
node -> WidgetNode s e
node
    Maybe (WidgetNode s e)
Nothing -> forall s e. WidgetNode s e
spacer
      forall t. CmbStyleBasic t => t -> [StyleState] -> t
`styleBasic` [forall t. CmbMaxWidth t => Double -> t
maxWidth Double
0.01, forall t. CmbMaxHeight t => Double -> t
maxHeight Double
0.01]

makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e -> WidgetNode s e
makeNode :: forall s e.
Widget s e -> WidgetNode s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
widget WidgetNode s e
anchor WidgetNode s e
content = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"popup" Widget s e
widget
  forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasFocusable s a => Lens' s a
L.focusable forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
  forall a b. a -> (a -> b) -> b
& forall s a. HasChildren s a => Lens' s a
L.children forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> Seq a
Seq.fromList [WidgetNode s e
anchor, WidgetNode s e
content]

anchorIdx :: Int
anchorIdx :: Int
anchorIdx = Int
0

contentIdx :: Int
contentIdx :: Int
contentIdx = Int
1

makePopup
  :: forall s e . WidgetModel s
  => WidgetData s Bool
  -> PopupCfg s e
  -> PopupState
  -> Widget s e
makePopup :: forall s e.
WidgetModel s =>
WidgetData s Bool -> PopupCfg s e -> PopupState -> Widget s e
makePopup WidgetData s Bool
field PopupCfg s e
config PopupState
state = Widget s e
widget where
  container :: Container s e PopupState
container = forall a. Default a => a
def {
    containerAddStyleReq :: Bool
containerAddStyleReq = Bool
False,
    containerInitPost :: ContainerInitPostHandler s e PopupState
containerInitPost = forall {p}.
WidgetEnv s e
-> p -> PopupState -> WidgetResult s e -> WidgetResult s e
initPost,
    containerMergePost :: ContainerMergePostHandler s e PopupState
containerMergePost = forall {p} {p} {p}.
WidgetEnv s e
-> p
-> p
-> PopupState
-> p
-> WidgetResult s e
-> WidgetResult s e
mergePost,
    containerHandleEvent :: ContainerEventHandler s e
containerHandleEvent = ContainerEventHandler s e
handleEvent,
    containerGetSizeReq :: ContainerGetSizeReqHandler s e
containerGetSizeReq = ContainerGetSizeReqHandler s e
getSizeReq,
    containerResize :: ContainerResizeHandler s e
containerResize = ContainerResizeHandler s e
resize
  }
  baseWidget :: Widget s e
baseWidget = forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer PopupState
state Container s e PopupState
container
  widget :: Widget s e
widget = Widget s e
baseWidget {
    widgetRender :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender = WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
  }

  initPost :: WidgetEnv s e
-> p -> PopupState -> WidgetResult s e -> WidgetResult s e
initPost WidgetEnv s e
wenv p
node PopupState
newState WidgetResult s e
result = WidgetResult s e
newResult where
    newResult :: WidgetResult s e
newResult = forall s e.
WidgetModel s =>
WidgetData s Bool
-> PopupCfg s e
-> PopupState
-> WidgetEnv s e
-> WidgetResult s e
-> WidgetResult s e
checkPopup WidgetData s Bool
field PopupCfg s e
config PopupState
newState WidgetEnv s e
wenv WidgetResult s e
result

  mergePost :: WidgetEnv s e
-> p
-> p
-> PopupState
-> p
-> WidgetResult s e
-> WidgetResult s e
mergePost WidgetEnv s e
wenv p
node p
oldNode PopupState
oldState p
newState WidgetResult s e
result = WidgetResult s e
newResult where
    newResult :: WidgetResult s e
newResult = forall s e.
WidgetModel s =>
WidgetData s Bool
-> PopupCfg s e
-> PopupState
-> WidgetEnv s e
-> WidgetResult s e
-> WidgetResult s e
checkPopup WidgetData s Bool
field PopupCfg s e
config PopupState
oldState WidgetEnv s e
wenv WidgetResult s e
result

  handleEvent :: ContainerEventHandler s e
handleEvent WidgetEnv s e
wenv WidgetNode s e
node Path
target SystemEvent
evt = case SystemEvent
evt of
    KeyAction KeyMod
mod KeyCode
code KeyStatus
KeyPressed
      | Bool
isCloseable Bool -> Bool -> Bool
&& KeyCode -> Bool
isKeyEscape KeyCode
code -> forall a. a -> Maybe a
Just WidgetResult s e
closeResult

    ButtonAction Point
point Button
button ButtonState
BtnReleased Int
clicks
      | Bool
isCloseable Bool -> Bool -> Bool
&& Bool -> Bool
not (Point -> Bool
insidePopup Point
point) -> forall a. a -> Maybe a
Just WidgetResult s e
closeResult

    Click Point
point Button
button Int
clicks
      | Bool
isCloseable Bool -> Bool -> Bool
&& Bool -> Bool
not (Point -> Bool
insidePopup Point
point) -> forall a. a -> Maybe a
Just WidgetResult s e
closeResult

    {-
    This check is needed because the anchor is inside the overlay, and otherwise
    it would receive events when the popup is open.
    -}
    SystemEvent
_
      | (Bool
isVisible Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isContentTarget) Bool -> Bool -> Bool
|| Bool
matchMs -> forall a. a -> Maybe a
Just WidgetResult s e
ignoreResult
      | Bool
otherwise -> forall a. Maybe a
Nothing

    where
      path :: Path
path = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasPath s a => Lens' s a
L.path

      disableClose :: Bool
disableClose = forall s e. PopupCfg s e -> Maybe Bool
_ppcDisableClose PopupCfg s e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True
      matchMs :: Bool
matchMs = PopupState -> Millisecond
_ppsReleaseMs PopupState
state forall a. Eq a => a -> a -> Bool
== WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTimestamp s a => Lens' s a
L.timestamp

      isVisible :: Bool
isVisible = forall s a. s -> WidgetData s a -> a
widgetDataGet (WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasModel s a => Lens' s a
L.model) WidgetData s Bool
field
      isContentTarget :: Bool
isContentTarget = Path -> Path -> Bool
isPathParent (Path
path forall s a. Snoc s s a a => s -> a -> s
|> Int
contentIdx) Path
target
      isCloseable :: Bool
isCloseable = Bool
isVisible Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
disableClose

      content :: WidgetNode s e
content = forall a. Seq a -> Int -> a
Seq.index (WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasChildren s a => Lens' s a
L.children) Int
contentIdx
      cviewport :: Rect
cviewport = WidgetNode s e
content forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasViewport s a => Lens' s a
L.viewport
      insidePopup :: Point -> Bool
insidePopup Point
point = Point -> Rect -> Bool
pointInRect Point
point Rect
cviewport

      closeResult :: WidgetResult s e
closeResult = forall s e.
WidgetModel s =>
WidgetData s Bool
-> PopupCfg s e
-> PopupState
-> WidgetEnv s e
-> WidgetNode s e
-> WidgetResult s e
closePopup WidgetData s Bool
field PopupCfg s e
config PopupState
state WidgetEnv s e
wenv WidgetNode s e
node
      ignoreResult :: WidgetResult s e
ignoreResult = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [forall s e. WidgetRequest s e
IgnoreChildrenEvents]

  getSizeReq :: ContainerGetSizeReqHandler s e
  getSizeReq :: ContainerGetSizeReqHandler s e
getSizeReq WidgetEnv s e
wenv WidgetNode s e
node Seq (WidgetNode s e)
children = (SizeReq
newReqW, SizeReq
newReqH) where
    anchor :: WidgetNode s e
anchor = forall a. Seq a -> Int -> a
Seq.index Seq (WidgetNode s e)
children Int
anchorIdx
    newReqW :: SizeReq
newReqW = WidgetNode s e
anchor forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSizeReqW s a => Lens' s a
L.sizeReqW
    newReqH :: SizeReq
newReqH = WidgetNode s e
anchor forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSizeReqH s a => Lens' s a
L.sizeReqH

  resize :: ContainerResizeHandler s e
  resize :: ContainerResizeHandler s e
resize WidgetEnv s e
wenv WidgetNode s e
node Rect
viewport Seq (WidgetNode s e)
children = (WidgetResult s e, Seq Rect)
resized where
    Size Double
ww Double
wh = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasWindowSize s a => Lens' s a
L.windowSize
    Rect Double
px Double
py Double
pw Double
ph = Rect
viewport
    Point Double
sx Double
sy = Point -> Point -> Point
subPoint (PopupState -> Point
_ppsClickPos PopupState
state) (WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasOffset s a => Lens' s a
L.offset)
    Point Double
ox Double
oy = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (forall s e. PopupCfg s e -> Maybe Point
_ppcOffset PopupCfg s e
config)

    alignOuterH :: Bool
alignOuterH = forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToOuterH PopupCfg s e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True
    alignOuterV :: Bool
alignOuterV = forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToOuterV PopupCfg s e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True
    alignWin :: Bool
alignWin = forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToWindow PopupCfg s e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True
    alignH :: Maybe AlignH
alignH = forall s e. PopupCfg s e -> Maybe AlignH
_ppcAlignH PopupCfg s e
config
    alignV :: Maybe AlignV
alignV = forall s e. PopupCfg s e -> Maybe AlignV
_ppcAlignV PopupCfg s e
config
    openAtCursor :: Bool
openAtCursor = forall s e. PopupCfg s e -> Maybe Bool
_ppcOpenAtCursor PopupCfg s e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True

    content :: WidgetNode s e
content = forall a. Seq a -> Int -> a
Seq.index Seq (WidgetNode s e)
children Int
contentIdx
    cw :: Double
cw = SizeReq -> Double
sizeReqMaxBounded (WidgetNode s e
content forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSizeReqW s a => Lens' s a
L.sizeReqW)
    ch :: Double
ch = SizeReq -> Double
sizeReqMaxBounded (WidgetNode s e
content forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSizeReqH s a => Lens' s a
L.sizeReqH)

    (Bool
alignL, Bool
alignR) = (Maybe AlignH
alignH forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just AlignH
ALeft, Maybe AlignH
alignH forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just AlignH
ARight)
    (Bool
alignT, Bool
alignB) = (Maybe AlignV
alignV forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just AlignV
ATop, Maybe AlignV
alignV forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just AlignV
ABottom)
    (Bool
alignC, Bool
alignM) = (Maybe AlignH
alignH forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just AlignH
ACenter, Maybe AlignV
alignV forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just AlignV
AMiddle)

    Rect Double
ax Double
ay Double
aw Double
ah
      | Bool
alignWin = Double -> Double -> Double -> Double -> Rect
Rect Double
0 Double
0 Double
ww Double
wh
      | Bool
otherwise = Rect
viewport

    (Double
atx, Double
arx)
      | Bool
alignOuterH = (Double
ax forall a. Num a => a -> a -> a
- Double
cw forall a. Num a => a -> a -> a
+ Double
ox, Double
ax forall a. Num a => a -> a -> a
+ Double
aw forall a. Num a => a -> a -> a
+ Double
ox)
      | Bool
otherwise = (Double
ax forall a. Num a => a -> a -> a
+ Double
ox, Double
ax forall a. Num a => a -> a -> a
+ Double
aw forall a. Num a => a -> a -> a
- Double
cw forall a. Num a => a -> a -> a
+ Double
ox)
    (Double
aty, Double
aby)
      | Bool
alignOuterV = (Double
ay forall a. Num a => a -> a -> a
- Double
ch forall a. Num a => a -> a -> a
+ Double
oy, Double
ay forall a. Num a => a -> a -> a
+ Double
ah forall a. Num a => a -> a -> a
+ Double
oy)
      | Bool
otherwise = (Double
ay forall a. Num a => a -> a -> a
+ Double
oy, Double
ay forall a. Num a => a -> a -> a
+ Double
ah forall a. Num a => a -> a -> a
- Double
ch forall a. Num a => a -> a -> a
+ Double
oy)

    Point Double
olx Double
oty = forall s e. WidgetEnv s e -> PopupCfg s e -> Rect -> Point
calcWindowOffset WidgetEnv s e
wenv PopupCfg s e
config (Double -> Double -> Double -> Double -> Rect
Rect Double
atx Double
aty Double
cw Double
ch)
    Point Double
orx Double
oby = forall s e. WidgetEnv s e -> PopupCfg s e -> Rect -> Point
calcWindowOffset WidgetEnv s e
wenv PopupCfg s e
config (Double -> Double -> Double -> Double -> Rect
Rect Double
arx Double
aby Double
cw Double
ch)

    fits :: a -> Bool
fits a
offset = forall a. Num a => a -> a
abs a
offset forall a. Ord a => a -> a -> Bool
< a
0.01 Bool -> Bool -> Bool
|| Bool
alignWin
    (Bool
fitL, Bool
fitR) = (forall {a}. (Ord a, Fractional a) => a -> Bool
fits Double
olx, forall {a}. (Ord a, Fractional a) => a -> Bool
fits Double
orx)
    (Bool
fitT, Bool
fitB) = (forall {a}. (Ord a, Fractional a) => a -> Bool
fits Double
oty, forall {a}. (Ord a, Fractional a) => a -> Bool
fits Double
oby)

    cx :: Double
cx
      | Bool
openAtCursor = Double
sx
      | Bool
alignC = Double
ax forall a. Num a => a -> a -> a
+ (Double
aw forall a. Num a => a -> a -> a
- Double
cw) forall a. Fractional a => a -> a -> a
/ Double
2
      | Bool
alignL Bool -> Bool -> Bool
&& (Bool
fitL Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
fitR) Bool -> Bool -> Bool
|| Bool
alignR Bool -> Bool -> Bool
&& Bool
fitL Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
fitR = Double
atx forall a. Num a => a -> a -> a
- Double
ox
      | Bool
alignR Bool -> Bool -> Bool
&& (Bool
fitR Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
fitL) Bool -> Bool -> Bool
|| Bool
alignL Bool -> Bool -> Bool
&& Bool
fitR Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
fitL = Double
arx forall a. Num a => a -> a -> a
- Double
ox
      | Bool
otherwise = Double
ax

    cy :: Double
cy
      | Bool
openAtCursor = Double
sy
      | Bool
alignM = Double
ay forall a. Num a => a -> a -> a
+ (Double
ah forall a. Num a => a -> a -> a
- Double
ch) forall a. Fractional a => a -> a -> a
/ Double
2
      | Bool
alignT Bool -> Bool -> Bool
&& (Bool
fitT Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
fitB) Bool -> Bool -> Bool
|| Bool
alignB Bool -> Bool -> Bool
&& Bool
fitT Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
fitB = Double
aty forall a. Num a => a -> a -> a
- Double
oy
      | Bool
alignB Bool -> Bool -> Bool
&& (Bool
fitB Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
fitT) Bool -> Bool -> Bool
|| Bool
alignT Bool -> Bool -> Bool
&& Bool
fitB Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
fitT = Double
aby forall a. Num a => a -> a -> a
- Double
oy
      | Bool
otherwise = Double
ay

    tmpArea :: Rect
tmpArea = Double -> Double -> Double -> Double -> Rect
Rect (Double
cx forall a. Num a => a -> a -> a
+ Double
ox) (Double
cy forall a. Num a => a -> a -> a
+ Double
oy) Double
cw Double
ch
    winOffset :: Point
winOffset = forall s e. WidgetEnv s e -> PopupCfg s e -> Rect -> Point
calcWindowOffset WidgetEnv s e
wenv PopupCfg s e
config Rect
tmpArea
    carea :: Rect
carea = Point -> Rect -> Rect
moveRect Point
winOffset Rect
tmpArea

    assignedAreas :: Seq Rect
assignedAreas = forall a. [a] -> Seq a
Seq.fromList [Rect
viewport, Rect
carea]
    resized :: (WidgetResult s e, Seq Rect)
resized = (forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node, Seq Rect
assignedAreas)

  render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
    forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender (WidgetNode s e
anchor forall s a. s -> Getting a s a -> a
^. forall s a. HasWidget s a => Lens' s a
L.widget) WidgetEnv s e
awenv WidgetNode s e
anchor Renderer
renderer

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isVisible forall a b. (a -> b) -> a -> b
$
      Renderer -> IO () -> IO ()
createOverlay Renderer
renderer forall a b. (a -> b) -> a -> b
$
        Renderer -> Point -> IO () -> IO ()
drawInTranslation Renderer
renderer Point
scrollOffset forall a b. (a -> b) -> a -> b
$ do
          forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender (WidgetNode s e
content forall s a. s -> Getting a s a -> a
^. forall s a. HasWidget s a => Lens' s a
L.widget) WidgetEnv s e
cwenv WidgetNode s e
content Renderer
renderer
    where
      isVisible :: Bool
isVisible = forall s a. s -> WidgetData s a -> a
widgetDataGet (WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasModel s a => Lens' s a
L.model) WidgetData s Bool
field

      alignWin :: Bool
alignWin = forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToWindow PopupCfg s e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True
      scrollOffset :: Point
scrollOffset
        | Bool
alignWin = forall a. Default a => a
def
        | Bool
otherwise = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasOffset s a => Lens' s a
L.offset

      anchor :: WidgetNode s e
anchor = forall a. Seq a -> Int -> a
Seq.index (WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasChildren s a => Lens' s a
L.children) Int
anchorIdx
      anchorVp :: Rect
anchorVp = WidgetNode s e
anchor forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasViewport s a => Lens' s a
L.viewport
      content :: WidgetNode s e
content = forall a. Seq a -> Int -> a
Seq.index (WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasChildren s a => Lens' s a
L.children) Int
contentIdx
      contentVp :: Rect
contentVp = WidgetNode s e
content forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasViewport s a => Lens' s a
L.viewport

      -- Hacky solution to avoid the anchor acting as if it were top-level.
      updateOverlay :: Maybe a -> Maybe a
updateOverlay Maybe a
overlay
        | Bool
isVisible = forall a. a -> Maybe a
Just (WidgetNode s e
content forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasPath s a => Lens' s a
L.path)
        | Bool
otherwise = Maybe a
overlay
      -- Update viewports to avoid clipping/scissoring issues.
      awenv :: WidgetEnv s e
awenv = forall s e a.
Container s e a
-> WidgetEnv s e -> WidgetNode s e -> Rect -> WidgetEnv s e
updateWenvOffset Container s e PopupState
container WidgetEnv s e
wenv WidgetNode s e
node Rect
anchorVp
        forall a b. a -> (a -> b) -> b
& forall s a. HasViewport s a => Lens' s a
L.viewport forall s t a b. ASetter s t a b -> b -> s -> t
.~ Rect
anchorVp
        forall a b. a -> (a -> b) -> b
& forall s a. HasOverlayPath s a => Lens' s a
L.overlayPath forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {a} {a}.
(HasInfo (WidgetNode s e) a, HasPath a a) =>
Maybe a -> Maybe a
updateOverlay
      cwenv :: WidgetEnv s e
cwenv = forall s e a.
Container s e a
-> WidgetEnv s e -> WidgetNode s e -> Rect -> WidgetEnv s e
updateWenvOffset Container s e PopupState
container WidgetEnv s e
wenv WidgetNode s e
node Rect
contentVp
        forall a b. a -> (a -> b) -> b
& forall s a. HasViewport s a => Lens' s a
L.viewport forall s t a b. ASetter s t a b -> b -> s -> t
.~ Rect
contentVp

calcWindowOffset :: WidgetEnv s e -> PopupCfg s e -> Rect -> Point
calcWindowOffset :: forall s e. WidgetEnv s e -> PopupCfg s e -> Rect -> Point
calcWindowOffset WidgetEnv s e
wenv PopupCfg s e
config Rect
viewport = Double -> Double -> Point
Point Double
offsetX Double
offsetY where
  alignWin :: Bool
alignWin = forall s e. PopupCfg s e -> Maybe Bool
_ppcAlignToWindow PopupCfg s e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True

  Size Double
winW Double
winH = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasWindowSize s a => Lens' s a
L.windowSize
  Rect Double
cx Double
cy Double
cw Double
ch
    | Bool
alignWin = Rect
viewport
    | Bool
otherwise = Point -> Rect -> Rect
moveRect (WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasOffset s a => Lens' s a
L.offset) Rect
viewport

  offsetX :: Double
offsetX
    | Double
cx forall a. Ord a => a -> a -> Bool
< Double
0 = -Double
cx
    | Double
cx forall a. Num a => a -> a -> a
+ Double
cw forall a. Ord a => a -> a -> Bool
> Double
winW = Double
winW forall a. Num a => a -> a -> a
- Double
cx forall a. Num a => a -> a -> a
- Double
cw
    | Bool
otherwise = Double
0
  offsetY :: Double
offsetY
    | Double
cy forall a. Ord a => a -> a -> Bool
< Double
0 = -Double
cy
    | Double
cy forall a. Num a => a -> a -> a
+ Double
ch forall a. Ord a => a -> a -> Bool
> Double
winH = Double
winH forall a. Num a => a -> a -> a
- Double
cy forall a. Num a => a -> a -> a
- Double
ch
    | Bool
otherwise = Double
0

checkPopup
  :: WidgetModel s
  => WidgetData s Bool
  -> PopupCfg s e
  -> PopupState
  -> WidgetEnv s e
  -> WidgetResult s e
  -> WidgetResult s e
checkPopup :: forall s e.
WidgetModel s =>
WidgetData s Bool
-> PopupCfg s e
-> PopupState
-> WidgetEnv s e
-> WidgetResult s e
-> WidgetResult s e
checkPopup WidgetData s Bool
field PopupCfg s e
config PopupState
state WidgetEnv s e
wenv WidgetResult s e
result = WidgetResult s e
newResult where
  node :: WidgetNode s e
node = WidgetResult s e
result forall s a. s -> Getting a s a -> a
^. forall s a. HasNode s a => Lens' s a
L.node
  shouldDisplay :: Bool
shouldDisplay = forall s a. s -> WidgetData s a -> a
widgetDataGet (WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasModel s a => Lens' s a
L.model) WidgetData s Bool
field
  isOverlay :: Bool
isOverlay = forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeInOverlay WidgetEnv s e
wenv WidgetNode s e
node

  (WidgetNode s e
newNode, [WidgetRequest s e]
newReqs)
    | Bool
shouldDisplay Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isOverlay = forall s e.
WidgetModel s =>
WidgetData s Bool
-> PopupCfg s e
-> PopupState
-> WidgetEnv s e
-> WidgetNode s e
-> (WidgetNode s e, [WidgetRequest s e])
showPopup WidgetData s Bool
field PopupCfg s e
config PopupState
state WidgetEnv s e
wenv WidgetNode s e
node
    | Bool -> Bool
not Bool
shouldDisplay Bool -> Bool -> Bool
&& Bool
isOverlay = forall s e.
PopupCfg s e
-> WidgetNode s e -> (WidgetNode s e, [WidgetRequest s e])
hidePopup PopupCfg s e
config WidgetNode s e
node
    | Bool
otherwise = (WidgetNode s e
node forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall s e.
WidgetModel s =>
WidgetData s Bool -> PopupCfg s e -> PopupState -> Widget s e
makePopup WidgetData s Bool
field PopupCfg s e
config PopupState
state, [])

  newResult :: WidgetResult s e
newResult = WidgetResult s e
result
    forall a b. a -> (a -> b) -> b
& forall s a. HasNode s a => Lens' s a
L.node forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ WidgetNode s e
newNode forall s a. s -> Getting a s a -> a
^. forall s a. HasWidget s a => Lens' s a
L.widget
    forall a b. a -> (a -> b) -> b
& forall s a. HasRequests s a => Lens' s a
L.requests forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ forall a. [a] -> Seq a
Seq.fromList [WidgetRequest s e]
newReqs

showPopup
  :: WidgetModel s
  => WidgetData s Bool
  -> PopupCfg s e
  -> PopupState
  -> WidgetEnv s e
  -> WidgetNode s e
  -> (WidgetNode s e, [WidgetRequest s e])
showPopup :: forall s e.
WidgetModel s =>
WidgetData s Bool
-> PopupCfg s e
-> PopupState
-> WidgetEnv s e
-> WidgetNode s e
-> (WidgetNode s e, [WidgetRequest s e])
showPopup WidgetData s Bool
field PopupCfg s e
config PopupState
state WidgetEnv s e
wenv WidgetNode s e
node = (WidgetNode s e
newNode, [WidgetRequest s e]
newReqs) where
  widgetId :: WidgetId
widgetId = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
  path :: Path
path = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasPath s a => Lens' s a
L.path
  mousePos :: Point
mousePos = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasInputStatus s a => Lens' s a
L.inputStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasMousePos s a => Lens' s a
L.mousePos

  anchor :: WidgetNode s e
anchor = forall a. Seq a -> Int -> a
Seq.index (WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasChildren s a => Lens' s a
L.children) Int
anchorIdx
  awidgetId :: WidgetId
awidgetId = WidgetNode s e
anchor forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId

  onChangeReqs :: [WidgetRequest s e]
onChangeReqs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ Bool
True) (forall s e. PopupCfg s e -> [Bool -> WidgetRequest s e]
_ppcOnChangeReq PopupCfg s e
config)
  showReqs :: [WidgetRequest s e]
showReqs = [
      forall s e. WidgetId -> WidgetRequest s e
ResizeWidgets WidgetId
widgetId,
      forall s e. WidgetId -> Path -> WidgetRequest s e
SetOverlay WidgetId
widgetId Path
path,
      forall s e. Maybe WidgetId -> FocusDirection -> WidgetRequest s e
MoveFocus (forall a. a -> Maybe a
Just WidgetId
awidgetId) FocusDirection
FocusFwd
    ]

  newState :: PopupState
newState = PopupState
state {
    _ppsClickPos :: Point
_ppsClickPos = Point
mousePos
  }
  newNode :: WidgetNode s e
newNode = WidgetNode s e
node
    forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall s e.
WidgetModel s =>
WidgetData s Bool -> PopupCfg s e -> PopupState -> Widget s e
makePopup WidgetData s Bool
field PopupCfg s e
config PopupState
newState
  newReqs :: [WidgetRequest s e]
newReqs = forall a. Monoid a => [a] -> a
mconcat [forall {s} {e}. [WidgetRequest s e]
showReqs, [WidgetRequest s e]
onChangeReqs]

hidePopup
  :: PopupCfg s e -> WidgetNode s e -> (WidgetNode s e, [WidgetRequest s e])
hidePopup :: forall s e.
PopupCfg s e
-> WidgetNode s e -> (WidgetNode s e, [WidgetRequest s e])
hidePopup PopupCfg s e
config WidgetNode s e
node = (WidgetNode s e
node, [WidgetRequest s e]
onChangeReqs forall a. Semigroup a => a -> a -> a
<> forall {s} {e}. [WidgetRequest s e]
hideReqs) where
  widgetId :: WidgetId
widgetId = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId

  content :: WidgetNode s e
content = forall a. Seq a -> Int -> a
Seq.index (WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasChildren s a => Lens' s a
L.children) Int
contentIdx
  cwidgetId :: WidgetId
cwidgetId = WidgetNode s e
content forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId

  onChangeReqs :: [WidgetRequest s e]
onChangeReqs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ Bool
False) (forall s e. PopupCfg s e -> [Bool -> WidgetRequest s e]
_ppcOnChangeReq PopupCfg s e
config)
  hideReqs :: [WidgetRequest s e]
hideReqs = [
      forall s e. WidgetId -> WidgetRequest s e
ResetOverlay WidgetId
widgetId,
      forall s e. Maybe WidgetId -> FocusDirection -> WidgetRequest s e
MoveFocus (forall a. a -> Maybe a
Just WidgetId
cwidgetId) FocusDirection
FocusBwd
    ]

closePopup
  :: WidgetModel s
  => WidgetData s Bool
  -> PopupCfg s e
  -> PopupState
  -> WidgetEnv s e
  -> WidgetNode s e
  -> WidgetResult s e
closePopup :: forall s e.
WidgetModel s =>
WidgetData s Bool
-> PopupCfg s e
-> PopupState
-> WidgetEnv s e
-> WidgetNode s e
-> WidgetResult s e
closePopup WidgetData s Bool
field PopupCfg s e
config PopupState
state WidgetEnv s e
wenv WidgetNode s e
node = WidgetResult s e
result where
  widgetId :: WidgetId
widgetId = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
  toggleShow :: [WidgetRequest s e]
toggleShow = forall s a e. WidgetData s a -> a -> [WidgetRequest s e]
widgetDataSet WidgetData s Bool
field Bool
False
  isOverlay :: Bool
isOverlay = forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeInOverlay WidgetEnv s e
wenv WidgetNode s e
node

  content :: WidgetNode s e
content = forall a. Seq a -> Int -> a
Seq.index (WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasChildren s a => Lens' s a
L.children) Int
contentIdx
  cwidgetId :: WidgetId
cwidgetId = WidgetNode s e
content forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId

  onChangeReqs :: [WidgetRequest s e]
onChangeReqs
    | Bool
isOverlay = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ Bool
False) (forall s e. PopupCfg s e -> [Bool -> WidgetRequest s e]
_ppcOnChangeReq PopupCfg s e
config)
    | Bool
otherwise = []
  closeReqs :: [WidgetRequest s e]
closeReqs = [
      forall s e. WidgetRequest s e
IgnoreChildrenEvents,
      forall s e. WidgetId -> WidgetRequest s e
ResetOverlay WidgetId
widgetId,
      forall s e. Maybe WidgetId -> FocusDirection -> WidgetRequest s e
MoveFocus (forall a. a -> Maybe a
Just WidgetId
cwidgetId) FocusDirection
FocusBwd
    ]

  newState :: PopupState
newState = PopupState
state {
    _ppsReleaseMs :: Millisecond
_ppsReleaseMs = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTimestamp s a => Lens' s a
L.timestamp
  }
  newNode :: WidgetNode s e
newNode = WidgetNode s e
node
    forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall s e.
WidgetModel s =>
WidgetData s Bool -> PopupCfg s e -> PopupState -> Widget s e
makePopup WidgetData s Bool
field PopupCfg s e
config PopupState
newState

  reqs :: [WidgetRequest s e]
reqs = forall a. Monoid a => [a] -> a
mconcat [forall {s} {e}. [WidgetRequest s e]
closeReqs, forall {e}. [WidgetRequest s e]
toggleShow, [WidgetRequest s e]
onChangeReqs]
  result :: WidgetResult s e
result = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [WidgetRequest s e]
reqs