Arbitrary precision float controller

-- Quality of life syntaxic sugar
{-# LANGUAGE OverloadedStrings, ImportQualifiedPost, NamedFieldPuns, BlockArguments, LambdaCase #-}

-- RankNTypes enables using Lens as function argument
{-# LANGUAGE RankNTypes #-}

-- To replace base with rio
{-# LANGUAGE NoImplicitPrelude #-}

import RIO
import Data.Text (pack)

import DearImGui qualified
import Data.StateVar qualified as StateVar

-- Necessary import to create the window and render the GUI
import Control.Monad.Managed (runManaged, managed, managed_)
import DearImGui.OpenGL3 qualified as DGL3
import DearImGui.SDL qualified as DSDL
import DearImGui.SDL.OpenGL qualified as DGL
import Graphics.GL qualified as GL
import SDL qualified

import Data.Scientific (Scientific)
import Data.Scientific qualified as Scientific

exp10L :: Lens' Scientific Int
exp10L = lens getv setv
  where
    getv :: Scientific -> Int
    getv = Scientific.base10Exponent
    setv :: Scientific -> Int -> Scientific
    setv s c = Scientific.scientific (Scientific.coefficient s) c

coefL :: Lens' Scientific Int
coefL = lens getv setv
  where
    -- This should be Integer, but dear-imgui works with Int.
    getv :: Scientific -> Int
    getv = fromInteger . Scientific.coefficient
    setv :: Scientific -> Int -> Scientific
    setv s c = Scientific.scientific (toInteger c) (Scientific.base10Exponent s)

example :: Scientific
example = 9001.42

demo :: [String]
demo = [
    show (coefL  `view` example),     -- 900142
    show (exp10L `view` example),     -- -2
    show ((coefL  `set` 42) example), -- 0.42
    show ((exp10L `set` 42) example)  -- 9.00142e47
  ]

-- note: this function definition requires the RankNTypes extension
makeStateLens :: TVar a -> Lens' a b -> StateVar.StateVar b
makeStateLens value valueLens = StateVar.makeStateVar getv setv
  where
    -- getv :: IO b
    getv = view valueLens <$> readTVarIO value
    -- setv :: b -> IO ()
    setv = atomically . modifyTVar' value . set valueLens

stateDemo :: IO String
stateDemo = do
  -- create the coef StateVar
  exampleVar <- newTVarIO example
  let coefVar = makeStateLens exampleVar coefL

  -- update the coef
  coefVar StateVar.$= 42

  -- Return "0.42"
  show <$> readTVarIO exampleVar

data FloatController = FloatController {
  value :: TVar Scientific.Scientific,
  output :: TVar Float
}

newFloatController :: Float -> STM FloatController
newFloatController initialValue =
  FloatController
    <$> newTVar (Scientific.fromFloatDigits initialValue)
    <*> newTVar initialValue

drawFloatController :: FloatController -> IO ()
drawFloatController FloatController{value, output} = do
  let
    coefVar = makeStateLens value coefL
    expVar = makeStateLens value exp10L

  -- we clamp the exponent between -38 and 38.
  whenM (DearImGui.dragInt "exp" expVar 1 (-38) 38) updateOutput
  whenM (DearImGui.dragInt "coef" coefVar 1 minBound maxBound) updateOutput
  DearImGui.text . mappend "Final value: " =<< pack . show <$> readTVarIO output
 where
  -- on change, we convert the scientific value to the float output.
  updateOutput = atomically do
    scientificValue <- readTVar value
    writeTVar output (Scientific.toRealFloat scientificValue)

drawFloatController' :: FloatController -> IO ()
drawFloatController' FloatController{value, output} = do
  let
    coefVar = makeStateLens value coefL
    expVar = makeStateLens value exp10L

  -- We pack all the elements tightly on a single line
  DearImGui.setNextItemWidth 40
  prevExp <- StateVar.get expVar
  whenM (DearImGui.dragInt "##exp" expVar 1 (-38) 38) do
    -- When the exponent value changes, we adjust the coefficient.
    newExp <- StateVar.get expVar
    let adjust coef
          | -- The exp decrease, so we adjust the coef
            newExp < prevExp = coef * 10
          | -- The exp increase and the coef can be reduced
            abs coef >= 10 = coef `div` 10
          | -- otherwise, we don't touch the coef
            otherwise = coef
    coefVar StateVar.$~! adjust

  DearImGui.sameLine
  DearImGui.setNextItemWidth 140
  whenM (DearImGui.dragInt "##coef" coefVar 1 minBound maxBound) $ atomically do
    -- When the coefficient changes, we update the final float value.
    scientificValue <- readTVar value
    writeTVar output (Scientific.toRealFloat scientificValue)
  DearImGui.sameLine

  DearImGui.text . mappend "value: " =<< pack . show <$> readTVarIO output

main :: IO ()
main = runSimpleApp do
  -- print example
  logInfo (displayShow demo)
  logInfo . displayShow =<< liftIO stateDemo

  floatController <- atomically (newFloatController 1)
  -- For this demo we'll draw the interface fullscreen:
  let doDrawGUI = DearImGui.withFullscreen (drawFloatController' floatController)

  SDL.initializeAll
  liftIO $ runManaged do
    window <- do
      let title = "Hello, Dear ImGui!"
      let config = SDL.defaultWindow { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL }
      managed $ bracket (SDL.createWindow title config) SDL.destroyWindow
    glContext <- managed $ bracket (SDL.glCreateContext window) SDL.glDeleteContext
    _ <- managed $ bracket DearImGui.createContext DearImGui.destroyContext
    _ <- managed_ $ bracket_ (DGL.sdl2InitForOpenGL window glContext) DSDL.sdl2Shutdown
    _ <- managed_ $ bracket_ DGL3.openGL3Init DGL3.openGL3Shutdown
    liftIO $ mainLoop window doDrawGUI


mainLoop :: SDL.Window -> IO () -> IO ()
mainLoop window doDrawGUI = unlessQuit do
  DGL3.openGL3NewFrame
  DSDL.sdl2NewFrame
  DearImGui.newFrame

  -- Build the GUI
  doDrawGUI

  GL.glClear GL.GL_COLOR_BUFFER_BIT
  DearImGui.render
  DGL3.openGL3RenderDrawData =<< DearImGui.getDrawData
  SDL.glSwapWindow window
  mainLoop window doDrawGUI

  where
    unlessQuit action = do
      shouldQuit <- checkEvents
      if shouldQuit then pure () else action
    checkEvents = do
      DSDL.pollEventWithImGui >>= \case
        Nothing ->
          return False
        Just event ->
          (isQuit event ||) <$> checkEvents
    isQuit event =
      SDL.eventPayload event == SDL.QuitEvent