{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo     #-}

module Potato.Reflex.Vty.Widget.Popup (
  popupPane
  , popupPaneSimple
) where

import           Relude

import           Potato.Reflex.Vty.Helpers
import           Potato.Reflex.Vty.Widget

import qualified Graphics.Vty.Input.Events as V
import           Reflex
import           Reflex.Network
import           Reflex.Potato.Helpers
import           Reflex.Vty

import           Data.Default

data PopupPaneSize = PopupPaneSize {
    PopupPaneSize -> Int
_popupPaneSize_minWidth      :: Int
    ,PopupPaneSize -> Int
_popupPaneSize_minHeight    :: Int
    , PopupPaneSize -> Float
_popupPaneSize_widthRatio  :: Float
    , PopupPaneSize -> Float
_popupPaneSize_heightRatio :: Float
  }

instance Default PopupPaneSize where
  def :: PopupPaneSize
def = Int -> Int -> Float -> Float -> PopupPaneSize
PopupPaneSize Int
0 Int
0 Float
0.5 Float
0.5

mulRatio :: Int -> Float -> Int
mulRatio :: Int -> Float -> Int
mulRatio Int
i Float
r =  forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*Float
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
i

type PopupInputWidget t m a =
  Event t () -- ^ escape button pressed
  -> Event t () -- ^ click outside box
  -> m (Event t (), Event t a) -- ^ (close event, output event)

-- TODO reduce constraints
popupPaneInternal :: forall t m a. (MonadWidget t m)
  => PopupPaneSize
  -> PopupInputWidget t m a -- ^ widget to be displayed in the popup
  -> m (Event t a, Event t ()) -- ^ (inner widget event, closed event)
popupPaneInternal :: forall t (m :: * -> *) a.
MonadWidget t m =>
PopupPaneSize
-> PopupInputWidget t m a -> m (Event t a, Event t ())
popupPaneInternal PopupPaneSize {Float
Int
_popupPaneSize_heightRatio :: Float
_popupPaneSize_widthRatio :: Float
_popupPaneSize_minHeight :: Int
_popupPaneSize_minWidth :: Int
_popupPaneSize_heightRatio :: PopupPaneSize -> Float
_popupPaneSize_widthRatio :: PopupPaneSize -> Float
_popupPaneSize_minHeight :: PopupPaneSize -> Int
_popupPaneSize_minWidth :: PopupPaneSize -> Int
..} PopupInputWidget t m a
widgetFnEv = do
  Dynamic t Int
screenWidthDyn <- forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayWidth
  Dynamic t Int
screenHeightDyn <- forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayHeight
  let
    widthDyn :: Dynamic t Int
widthDyn = forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Dynamic t Int
screenWidthDyn (\Int
sw -> forall a. Ord a => a -> a -> a
max (Int -> Float -> Int
mulRatio Int
sw Float
_popupPaneSize_widthRatio) Int
_popupPaneSize_minWidth)
    heightDyn :: Dynamic t Int
heightDyn = forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Dynamic t Int
screenHeightDyn (\Int
sh -> forall a. Ord a => a -> a -> a
max (Int -> Float -> Int
mulRatio Int
sh Float
_popupPaneSize_heightRatio) Int
_popupPaneSize_minHeight)
    regionDyn :: Dynamic t Region
regionDyn = forall (f :: * -> *) a b c.
Applicative f =>
f a -> f b -> (a -> b -> c) -> f c
ffor2 ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Int
screenWidthDyn forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Int
screenHeightDyn) ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Int
widthDyn forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Int
heightDyn) forall a b. (a -> b) -> a -> b
$ \(Int
sw,Int
sh) (Int
w,Int
h) -> Region {
        _region_left :: Int
_region_left = (Int
sw forall a. Num a => a -> a -> a
- Int
w) forall a. Integral a => a -> a -> a
`div` Int
2
        , _region_top :: Int
_region_top = (Int
sh forall a. Num a => a -> a -> a
- Int
h) forall a. Integral a => a -> a -> a
`div` Int
2
        , _region_width :: Int
_region_width = Int
w
        , _region_height :: Int
_region_height = Int
h
      }
  Event t KeyCombo
escapeEv <- forall {k} (m :: * -> *) (t :: k).
(Monad m, Reflex t, HasInput t m) =>
Key -> m (Event t KeyCombo)
key Key
V.KEsc
  Event t MouseDown
outsideMouseEv <- forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasInput t m) =>
Button -> m (Event t MouseDown)
mouseDown Button
V.BLeft
  (Event t a
outputEv, Event t ()
closeEv) <- forall {k} (m :: * -> *) (t :: k) a.
(MonadFix m, MonadHold t m, HasInput t m, HasImageWriter t m,
 HasDisplayRegion t m, HasFocusReader t m) =>
Dynamic t Region -> Dynamic t Bool -> m a -> m a
pane Dynamic t Region
regionDyn (forall {k} (t :: k) a. Reflex t => a -> Dynamic t a
constDyn Bool
True) forall a b. (a -> b) -> a -> b
$ do
    Event t MouseDown
insideMouseEv <- forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasInput t m) =>
Button -> m (Event t MouseDown)
mouseDown Button
V.BLeft
    (Event t ()
closeEv', Event t a
outputEv') <- PopupInputWidget t m a
widgetFnEv (forall (f :: * -> *) a. Functor f => f a -> f ()
void Event t KeyCombo
escapeEv) (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a b.
Reflex t =>
Event t a -> Event t b -> Event t a
difference Event t MouseDown
outsideMouseEv Event t MouseDown
insideMouseEv)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Event t a
outputEv', Event t ()
closeEv')
  forall (m :: * -> *) a. Monad m => a -> m a
return (Event t a
outputEv, Event t ()
closeEv)

-- TODO reduce constraints
-- | popupPane can only emit a single event before closing itself
-- clicking outside the popup closes the popup and emits no events (conisder disabling this as default behavior?)
popupPane :: forall t m a. (MonadWidget t m)
  => PopupPaneSize
  -> Event t (PopupInputWidget t m a)
  -> m (Event t a, Dynamic t Bool) -- ^ (inner widget event, popup state)
popupPane :: forall t (m :: * -> *) a.
MonadWidget t m =>
PopupPaneSize
-> Event t (PopupInputWidget t m a)
-> m (Event t a, Dynamic t Bool)
popupPane PopupPaneSize
size Event t (PopupInputWidget t m a)
widgetEv = mdo
  let
    emptyPopupWidget :: p -> p -> m (Event t a, Event t a)
emptyPopupWidget p
_ p
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (forall {k} (t :: k) a. Reflex t => Event t a
never, forall {k} (t :: k) a. Reflex t => Event t a
never)
    inputEv :: Event t (PopupInputWidget t m a)
inputEv = forall {k} (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost [Event t (PopupInputWidget t m a)
widgetEv, Event t ()
canceledEv forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall {t} {t} {m :: * -> *} {p} {p} {a} {a}.
(Reflex t, Reflex t, Monad m) =>
p -> p -> m (Event t a, Event t a)
emptyPopupWidget]
  Dynamic t (Event t a, Event t ())
innerDynEv :: Dynamic t (Event t a, Event t ())
    <- forall t (m :: * -> *) a.
(Adjustable t m, MonadHold t m) =>
m a -> Event t (m a) -> m (Dynamic t a)
networkHold (forall (m :: * -> *) a. Monad m => a -> m a
return (forall {k} (t :: k) a. Reflex t => Event t a
never, forall {k} (t :: k) a. Reflex t => Event t a
never)) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall t (m :: * -> *) a.
MonadWidget t m =>
PopupPaneSize
-> PopupInputWidget t m a -> m (Event t a, Event t ())
popupPaneInternal PopupPaneSize
size) Event t (PopupInputWidget t m a)
inputEv)
  let
    innerWidgetEv :: Event t a
innerWidgetEv = forall {k} (t :: k) a.
Reflex t =>
Dynamic t (Event t a) -> Event t a
switchDyn (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Dynamic t (Event t a, Event t ())
innerDynEv)
    canceledEv :: Event t ()
canceledEv = forall {k} (t :: k) a.
Reflex t =>
Dynamic t (Event t a) -> Event t a
switchDyn (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Dynamic t (Event t a, Event t ())
innerDynEv)
  Dynamic t Bool
outputStateDyn <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn Bool
False forall a b. (a -> b) -> a -> b
$ forall t a. Reflex t => String -> [Event t a] -> Event t a
leftmostWarn String
"popupOverride" [Event t (PopupInputWidget t m a)
widgetEv forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True, Event t ()
canceledEv forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False]
  forall (m :: * -> *) a. Monad m => a -> m a
return (Event t a
innerWidgetEv, Dynamic t Bool
outputStateDyn)


-- | a simple popup pane
-- the inner popup pane event closes the popup pane (e.g. notification dialog box with "ok" button)
-- clicking outside or pressing escape closes the popup and emits no events
popupPaneSimple :: forall t m a. (MonadWidget t m)
  => PopupPaneSize
  -> Event t (m (Event t a)) -- ^ when inner event fires, popup is disabled
  -> m (Event t a, Dynamic t Bool) -- ^ (inner widget event, popup state)
popupPaneSimple :: forall t (m :: * -> *) a.
MonadWidget t m =>
PopupPaneSize
-> Event t (m (Event t a)) -> m (Event t a, Dynamic t Bool)
popupPaneSimple PopupPaneSize
size Event t (m (Event t a))
widgetEv = forall t (m :: * -> *) a.
MonadWidget t m =>
PopupPaneSize
-> Event t (PopupInputWidget t m a)
-> m (Event t a, Dynamic t Bool)
popupPane PopupPaneSize
size Event t (Event t () -> Event t () -> m (Event t (), Event t a))
fancyWidgetEv where
  fmapfn :: f (Event t a)
-> Event t () -> Event t () -> f (Event t (), Event t a)
fmapfn f (Event t a)
w = \Event t ()
escEv Event t ()
clickOutsideEv -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Event t a
outputEv -> (forall {k} (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost [Event t ()
escEv, Event t ()
clickOutsideEv, forall (f :: * -> *) a. Functor f => f a -> f ()
void Event t a
outputEv], Event t a
outputEv)) f (Event t a)
w
  fancyWidgetEv :: Event t (Event t () -> Event t () -> m (Event t (), Event t a))
fancyWidgetEv = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {t} {f :: * -> *} {a}.
(Reflex t, Functor f) =>
f (Event t a)
-> Event t () -> Event t () -> f (Event t (), Event t a)
fmapfn Event t (m (Event t a))
widgetEv