{-# LANGUAGE OverloadedStrings #-}

module NanoUI.Widgets.Overlay
  ( modal
  , window
  )
where

import Control.Monad (void, when)
import Data.IntMap.Strict qualified as IM
import Data.Text (Text)
import Data.Text qualified as T
import Effectful (Eff, type (:>))
import NanoUI.Context
  ( Context (..)
  , beginModal
  , endModal
  , getPrevRect
  , getStore
  , intKey
  , seedFloatingPanel
  )
import NanoUI.Id (WidgetId)
import NanoUI.Input
  ( inputWindowSize
  )
import NanoUI.Layout.Arena (NodeType (..), addNode)
import NanoUI.Monad
  ( Ui
  , askContext
  , askInput
  , uiIO
  , withKey
  )
import NanoUI.Store (WidgetStore (..), slotKey, Slot (..))
import NanoUI.Style
  ( AlignX (..)
  , AlignY (..)
  , Direction (..)
  , Padding (..)
  , Sizing (..)
  , grow
  , padB
  , padT
  , tight
  , windowMargin
  , windowPad
  )
import NanoUI.Types (Rect (..), Size (..), rectNonEmpty)
import NanoUI.Widgets.Chrome
  ( closeButton
  , floatMinFor
  , modalTitleBarH
  , titleBarChromeHFor
  , titleBarLayoutFor
  , titleLabelLayoutFor
  )
import NanoUI.Widgets.Popup (floatingOverlay)
import NanoUI.Widgets.Layout
  ( flex
  , labelEx
  , row'
  , scrollWith
  , separator
  )
import NanoUI.Widgets.Node
  ( Response (..)
  , respClicked
  )

data OverlayKind
  = ModalOverlay
  | WindowOverlay
  deriving OverlayKind -> OverlayKind -> Bool
(OverlayKind -> OverlayKind -> Bool)
-> (OverlayKind -> OverlayKind -> Bool) -> Eq OverlayKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OverlayKind -> OverlayKind -> Bool
== :: OverlayKind -> OverlayKind -> Bool
$c/= :: OverlayKind -> OverlayKind -> Bool
/= :: OverlayKind -> OverlayKind -> Bool
Eq

modal :: Ui :> es => Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)
modal :: forall (es :: [Effect]) a.
(Ui :> es) =>
Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)
modal = OverlayKind
-> Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)
forall (es :: [Effect]) a.
(Ui :> es) =>
OverlayKind
-> Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)
overlay OverlayKind
ModalOverlay

window :: Ui :> es => Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)
window :: forall (es :: [Effect]) a.
(Ui :> es) =>
Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)
window = OverlayKind
-> Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)
forall (es :: [Effect]) a.
(Ui :> es) =>
OverlayKind
-> Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)
overlay OverlayKind
WindowOverlay

overlay ::
  Ui :> es =>
  OverlayKind -> Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)
overlay :: forall (es :: [Effect]) a.
(Ui :> es) =>
OverlayKind
-> Bool -> Text -> Eff es a -> Eff es (Response, Maybe a)
overlay OverlayKind
kind Bool
open Text
title Eff es a
child = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  inp <- askInput
  let
    Size winW winH = inputWindowSize inp
    margin = Float
windowMargin
    availW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 (Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
margin)
    availH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 (Float
winH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
margin)
    isModal = OverlayKind
kind OverlayKind -> OverlayKind -> Bool
forall a. Eq a => a -> a -> Bool
== OverlayKind
ModalOverlay
    -- Modals share the window's side padding. The body's scrollbar sits
    -- out in it just inside the panel's edge, that padding from the
    -- content.
    padding = if Bool
isModal then Padding
windowPad {padB = 12} else Padding
windowPad
    barH = if Bool
isModal then Float
modalTitleBarH else Float
titleBarChromeHFor
    -- Window body breathing room: one side-pad between the chrome and
    -- the body, matching the window's left/right padding. Modals keep
    -- their own larger gap.
    bodyGap = if Bool
isModal then Float
8 else Float
10
    minWidth =
      Float -> Float -> Float
floatMinFor
        (if Bool
isModal then Float
260 else Float
280)
        Float
availW
    minHeight =
      if Bool
isModal
        then Float
0
        else
          Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
availH (Padding -> Float
padT Padding
padding Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
titleBarChromeHFor Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
bodyGap Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Padding -> Float
padB Padding
padding)
    addOverlayNode WidgetId
_ Int
parent =
      NodeArena
-> NodeType
-> Int
-> Direction
-> Sizing
-> Sizing
-> Padding
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> AlignX
-> AlignY
-> IO Int
addNode
        (Context -> NodeArena
ctxNodeArena Context
ctx)
        (if Bool
isModal then NodeType
NodeModal else NodeType
NodeWindow)
        Int
parent
        Direction
Column
        Sizing
Fit
        Sizing
Fit
        Padding
padding
        Float
bodyGap
        Float
minWidth
        Float
minHeight
        Float
availW
        Float
availH
        Float
0
        AlignX
AlignStart
        AlignY
AlignTop
    enter WidgetId
wid = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isModal (Context -> IO ()
beginModal Context
ctx)
      Context -> WidgetId -> Rect -> IO ()
seedFloatingPanel Context
ctx WidgetId
wid
        (Rect -> IO ()) -> IO Rect -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Context
-> WidgetId
-> Bool
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO Rect
floatingSeedRect Context
ctx WidgetId
wid Bool
isModal Float
minWidth Float
minHeight Float
margin Float
winW Float
winH
    titleLabel = 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 -> Layout
titleLabelLayoutFor Float
barH) Text
title)
  floatingOverlay open isModal addOverlayNode enter $ do
    close <-
      row' (titleBarLayoutFor barH) $ do
        when (not (T.null title)) $
          case kind of
            OverlayKind
ModalOverlay -> Eff es ()
titleLabel
            OverlayKind
WindowOverlay -> Text -> Eff es () -> Eff es ()
forall k (es :: [Effect]) a.
(Hashable k, Ui :> es) =>
k -> Eff es a -> Eff es a
withKey Text
title Eff es ()
titleLabel
        flex
        withKey ("close" :: Text) closeButton
    when (isModal && not (T.null title)) separator
    r <- scrollWith (tight . grow) child
    when isModal (uiIO (endModal ctx))
    pure (respClicked close, r)

floatingSeedRect ::
  Context
  -> WidgetId
  -> Bool
  -> Float
  -> Float
  -> Float
  -> Float
  -> Float
  -> IO Rect
floatingSeedRect :: Context
-> WidgetId
-> Bool
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO Rect
floatingSeedRect Context
ctx WidgetId
wid Bool
isModal Float
minWidth Float
minHeight Float
margin Float
winW Float
winH = do
  mPrev <- Context -> WidgetId -> IO (Maybe Rect)
getPrevRect Context
ctx WidgetId
wid
  case mPrev of
    Just Rect
r | Rect -> Bool
rectNonEmpty Rect
r -> Rect -> IO Rect
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rect
r
    Maybe Rect
_ -> do
      store <- Context -> IO WidgetStore
getStore Context
ctx
      let
        k = WidgetId -> Int
intKey WidgetId
wid
        pos = Int -> IntMap (Float, Float) -> Maybe (Float, Float)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
store)
        sz = Int -> IntMap (Float, Float) -> Maybe (Float, Float)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Slot -> Int -> Int
slotKey Slot
SlotWinSize Int
k) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
store)
      pure $
        case (pos, sz) of
          (Just (Float
x, Float
y), Just (Float
w, Float
h)) | Float
w Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Float
h Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 -> Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
          (Just (Float
x, Float
y), Maybe (Float, Float)
_) -> Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
minWidth (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
minHeight Float
1)
          (Maybe (Float, Float), Maybe (Float, Float))
_ ->
            let
              w :: Float
w = Float
minWidth
              h :: Float
h = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
minHeight Float
1
             in
              if Bool
isModal
                then Float -> Float -> Float -> Float -> Rect
Rect ((Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
w) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) ((Float
winH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
h) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Float
w Float
h
                else Float -> Float -> Float -> Float -> Rect
Rect (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
margin)) Float
margin Float
w Float
h