Window.hs

module Render.ImGui.Window
  ( Window(..)
  , pack
  , toView
  , setNextWindowBox
  , run
  ) where

import RIO

import Data.Bits ((.|.))
import Data.ByteString.Unsafe (unsafeInit, unsafeUseAsCString)
import DearImGui.Raw qualified as Raw
import Foreign (castPtr, free, new, nullPtr, peek, with)
import Foreign.C.Types (CFloat(..))
import Geomancy (Vec2, vec2)
import Geomancy.Layout.Box (Box(..))
import Geomancy.Layout.View as LV
import GHC.OverloadedLabels (IsLabel(..))
import GHC.Records (HasField(..))
import GHC.TypeLits (KnownSymbol, symbolVal)

data Window = Window
  { name0 :: ByteString -- ^ NUL-terminated UTF-8 encoded name for less copying.
  , contentSize :: Maybe Vec2 -- ^ Set content size (~ scrollable client area, which enforce the range of scrollbars). Not including window decorations (title bar, menu bar, etc.) nor WindowPadding.
  , sizeConstraints :: Maybe (Vec2, Vec2) -- ^ Set size limits. use -1,-1 on either X/Y axis to preserve the current size. Sizes will be rounded down.
  , collapsed :: Maybe Bool -- ^ Set collapsed state.
  , focus :: Bool -- ^ Set focus state.
  , scroll :: Maybe Vec2 -- ^ Set scrolling value (use < 0.0f to not affect a given axis).
  , bgAlpha :: Maybe Float -- ^ Set background color alpha. helper to easily override the Alpha component of ImGuiCol_WindowBg, ChildBg, PopupBg. you may also use ImGuiWindowFlags_NoBackground.
  , flags :: Raw.ImGuiWindowFlags -- ^ Set window flags.
  , onClose :: Maybe (IO ()) -- ^ Allow window to be closed and set a callback.
  }

instance HasField "name" Window Text where
  getField Window{name0} = decodeUtf8Lenient (unsafeInit name0)

instance IsString Window where
  fromString = pack . fromString

instance KnownSymbol label => IsLabel label Window where
  fromLabel = base{flags = base.flags .|. Raw.ImGuiWindowFlags_NoTitleBar}
    where
      base = pack . fromString . ("##" ++) . symbolVal $ Proxy @label

pack :: Text -> Window
pack name = Window
  { name0 = encodeUtf8 $ name <> "\0"
  , contentSize = Nothing
  , sizeConstraints = Nothing
  , collapsed = Nothing
  , scroll = Nothing
  , focus = False
  , bgAlpha = Nothing
  , flags = Raw.ImGuiWindowFlags_NoSavedSettings
  , onClose = Nothing
  }

{- | ImGui windows as Views

@
hstack_ -- Split-screen with equally-sized windows
  [ Window.toView "Hi" $ ImGui.text "hi" -- title and default options
  , Window.toView #AnonWithID $ ImGui.text "hi" -- empty title with a hidden ID (and default options)
  , Window.toView example $ ImGui.text "hi" -- reusable window value
  ]
@
-}
toView :: Window -> m () -> View () (Windowed m)
toView config action = LV.view_ Windowed{..}

data Windowed m = Windowed
  { config :: Window
  , action :: m ()
  }

instance MonadUnliftIO m => LayoutView (Windowed m) where
  type Placed (Windowed m) = m ()
  placeView box Windowed{..} = do
    setNextWindowBox box
    let
      flags =
        config.flags .|.
        Raw.ImGuiWindowFlags_NoMove .|.
        Raw.ImGuiWindowFlags_NoResize .|.
        Raw.ImGuiWindowFlags_NoCollapse
    run (config{flags}) action

run :: MonadUnliftIO m => Window -> m () -> m ()
run window action = do
  liftIO do
    for_ window.contentSize \size ->
      with size $ Raw.setNextWindowContentSize . castPtr
    for_ (window.sizeConstraints <|> (Just (-1, -1))) \(minSize, maxSize) ->
      with minSize \minPtr ->
        with maxSize \maxPtr ->
          Raw.setNextWindowSizeConstraints (castPtr minPtr) (castPtr maxPtr)
    for_ window.collapsed $ \collapsed ->
      Raw.setNextWindowCollapsed (bool 0 1 collapsed) Raw.ImGuiCond_Always
    when window.focus Raw.setNextWindowFocus
    for_ window.scroll \scroll ->
      with scroll $ Raw.setNextWindowScroll . castPtr
    for_ window.bgAlpha $
      Raw.setNextWindowBgAlpha . CFloat

  bracket
    ( liftIO do
        open_ <- for window.onClose \callback -> (callback,) <$> new 1
        unsafeUseAsCString window.name0 \namePtr ->
          (open_,) <$> Raw.begin namePtr (Just $ maybe nullPtr snd open_) (Just window.flags)
    )
    ( \(open_, _) -> liftIO do
      case open_ of
        Just (callback, openPtr) | openPtr /= nullPtr -> do
          stillOpen <- peek openPtr
          Raw.end
          free openPtr
          when (stillOpen == 0) callback
        _ -> Raw.end
    )
    (\(_openPtr, visible) -> when visible action)

{-# INLINE setNextWindowBox #-}
setNextWindowBox :: MonadIO m => Box -> m ()
setNextWindowBox box = liftIO do
  with box.position \pos ->
    with (vec2 0.5 0.5) \pivot ->
      Raw.setNextWindowPos (castPtr pos) Raw.ImGuiCond_Always (Just $ castPtr pivot)
  with box.size \size ->
    Raw.setNextWindowSize (castPtr size) Raw.ImGuiCond_Always