{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

{-|
Module: DearImGui.FontAtlas

Font atlas builder, accompanied with lower-level functions.

@
import qualified DearImGui.FontAtlas as FontAtlas

prepareAtlas =
  FontAtlas.rebuild
    [ FontAtlas.FileTTF "comic-sans-mono.ttf" 13 csOptions csRanges
    , FontAtlas.Default
    ]
  where
    csOptions = mconcat
      [ FontAtlas.fontNo 1
      , FontAtlas.glyphOffset (0, -1)
      ]

    csRanges = RangeBuilder $ mconcat
      [ FontAtlas.addText "Hello world"
      , FontRanges.addChar 'Ꙑ'
      , FontRanges.addRanges FontRanges.Korean
      ]
@

-}

module DearImGui.FontAtlas
  ( -- * Main types
    Raw.Font(..)
  , FontSource(..)
    -- * Building atlas
  , rebuild
    -- ** Configuring sources
  , ConfigSetup(..)
  , fontDataOwnedByAtlas
  , fontNo
  , sizePixels
  , oversampleH
  , oversampleV
  , pixelSnapH
  , glyphExtraSpacing
  , glyphOffset
  , glyphRanges
  , glyphMinAdvanceX
  , glyphMaxAdvanceX
  , mergeMode
  , fontBuilderFlags
  , rasterizerMultiply
  , ellipsisChar

    -- ** Configuring ranges
  , Ranges(..)
  , RangesBuilderSetup(..)
  , addChar
  , addText
  , addRanges
  , addRangesRaw

  , pattern Latin
  , pattern Korean
  , pattern Japanese
  , pattern ChineseFull
  , pattern ChineseSimplifiedCommon
  , pattern Cyrillic
  , pattern Thai
  , pattern Vietnamese

    -- * Lower level types and functions
  -- , Raw.FontConfig(..)
  -- , Raw.GlyphRanges(..)
  , build
  , clear
  , setupFont
  , setupRanges
  , withRanges
  , withConfig
  , addFontFromFileTTF
  , addFontFromFileTTF_
  )
  where

-- base
import Data.Bool (bool)
import Data.Maybe (fromMaybe)
import Foreign
import Foreign.C

-- transformers
import Control.Monad.IO.Class
  ( MonadIO, liftIO )

-- managed
import Control.Monad.Managed
  ( MonadManaged, managed )
import qualified Control.Monad.Managed as Managed

-- unlift
import UnliftIO (MonadUnliftIO)
import UnliftIO.Exception (bracket)

-- dear-imgui
import DearImGui.Raw.Font (Font(..))
import qualified DearImGui.Raw.Font as Raw
import DearImGui.Raw.Font.Config (FontConfig(..))
import qualified DearImGui.Raw.Font.Config as FontConfig
import DearImGui.Raw.Font.GlyphRanges (GlyphRanges(..), GlyphRangesBuilder(..))
import qualified DearImGui.Raw.Font.GlyphRanges as GlyphRanges
import DearImGui.Internal.Text (Text)
import qualified DearImGui.Internal.Text as Text

import DearImGui.Structs (ImVec2(..), ImWchar)

-- | Font setup data
data FontSource
  = DefaultFont
  | FromTTF FilePath Float (Maybe ConfigSetup) Ranges
  -- TODO: FromMemory

-- | Font config monoid interface to be used in 'FontSource'.
--
-- @
-- mergeMode True <> fontNo 1
-- @
newtype ConfigSetup = ConfigSetup
  { applyToConfig :: FontConfig -> IO ()
  }

instance Semigroup ConfigSetup where
  ConfigSetup f <> ConfigSetup g =
    ConfigSetup \fc -> f fc >> g fc
instance Monoid ConfigSetup where
  mempty = ConfigSetup (const mempty)

-- | Glyph ranges settings, from presets to builder configuration.
data Ranges
  = RangesRaw GlyphRanges
  | RangesBuiltin GlyphRanges.Builtin
  | RangesBuilder RangesBuilderSetup

-- | Basic Latin, Extended Latin
pattern Latin :: Ranges
pattern Latin = RangesBuiltin GlyphRanges.Latin

-- | Default + Korean characters
pattern Korean :: Ranges
pattern Korean = RangesBuiltin GlyphRanges.Korean

-- | Default + Hiragana, Katakana, Half-Width, Selection of 2999 Ideographs
pattern Japanese :: Ranges
pattern Japanese = RangesBuiltin GlyphRanges.Japanese

-- | Default + Half-Width + Japanese Hiragana/Katakana + full set of about 21000 CJK Unified Ideographs
pattern ChineseFull :: Ranges
pattern ChineseFull = RangesBuiltin GlyphRanges.ChineseFull

-- | Default + Half-Width + Japanese Hiragana/Katakana + set of 2500 CJK Unified Ideographs for common simplified Chinese
pattern ChineseSimplifiedCommon :: Ranges
pattern ChineseSimplifiedCommon = RangesBuiltin GlyphRanges.ChineseSimplifiedCommon

-- | Default + about 400 Cyrillic characters
pattern Cyrillic :: Ranges
pattern Cyrillic = RangesBuiltin GlyphRanges.Cyrillic

-- | Default + Thai characters
pattern Thai :: Ranges
pattern Thai = RangesBuiltin GlyphRanges.Thai

-- | Default + Vietnamese characters
pattern Vietnamese :: Ranges
pattern Vietnamese = RangesBuiltin GlyphRanges.Vietnamese


-- | Ranges builder monoid interface to be executed through 'buildRanges'.
--
-- @
-- addRanges FontRanges.DefaultRanges <> addText "Привет"
-- @
newtype RangesBuilderSetup = RangesBuilderSetup
  { applyToBuilder :: GlyphRangesBuilder -> IO ()
  }

instance Semigroup RangesBuilderSetup where
  RangesBuilderSetup f <> RangesBuilderSetup g =
    RangesBuilderSetup \fc -> f fc >> g fc

instance Monoid RangesBuilderSetup where
  mempty = RangesBuilderSetup (const mempty)

-- | Rebuild font atlas with provided configuration
-- and return corresponding structure of font handles
-- to be used with 'withFont'.
--
-- Accepts any 'Traversable' instance, so you are free to use
-- lists, maps or custom structures.
rebuild :: (MonadIO m, Traversable t) => t FontSource -> m (t Font)
rebuild sources = liftIO $ Managed.with action pure
  where
    action = do
      clear
      fonts <- traverse setupFont sources
      build
      return fonts

-- | Reset font atlas, clearing internal data
--
-- Alias for 'Raw.clearFontAtlas'
clear :: (MonadIO m) => m ()
clear = Raw.clearFontAtlas

-- | Build font atlas
--
-- Alias for 'Raw.buildFontAtlas'
build :: (MonadIO m) => m ()
build = Raw.buildFontAtlas

-- | Load a font from TTF file.
--
-- Specify font path and atlas glyph size.
--
-- Use 'Raw.addFontDefault' if you want to retain built-in font too.
--
-- Call 'build' after adding all the fonts,
-- particularly if you're loading them from memory or use custom glyphs.
-- Or stick to `rebuild` function.
--
-- Call backend-specific `CreateFontsTexture` before using 'newFrame'.
addFontFromFileTTF :: MonadIO m
  => FilePath               -- ^ Font file path
  -> Float                  -- ^ Font size in pixels
  -> Maybe FontConfig   -- ^ Configuration data
  -> Maybe GlyphRanges  -- ^ Glyph ranges to use
  -> m (Maybe Font)     -- ^ Returns font handle, if added successfully
addFontFromFileTTF font size config ranges = liftIO do
  res@(Font ptr) <- withCString font \fontPtr ->
    Raw.addFontFromFileTTF
      fontPtr
      (CFloat size)
      (fromMaybe (FontConfig nullPtr) config)
      (fromMaybe (GlyphRanges nullPtr) ranges)
  pure $
    if castPtr ptr == nullPtr
      then Nothing
      else Just res
      -- FIXME: turn off asserts, so it would work

addFontFromFileTTF_ :: MonadIO m
  => FilePath           -- ^ Font file path
  -> Float              -- ^ Font size in pixels
  -> m (Maybe Raw.Font) -- ^ Returns font handle, if added successfully
addFontFromFileTTF_ font size =
  addFontFromFileTTF font size Nothing Nothing

-- | Load a font with provided configuration, return its handle
-- and defer range builder and config destructors, if needed.
setupFont :: (MonadManaged m) => FontSource -> m Font
setupFont = \case
  DefaultFont ->
    Raw.addFontDefault
  FromTTF path size configSetup ranges -> do
    glyphRanges' <- setupRanges ranges
    config <- managed (withConfig configSetup)
    mFont <- addFontFromFileTTF path size config glyphRanges'
    case mFont of
      Nothing ->
        liftIO . fail $ "Couldn't load font from " <> path
      Just font ->
        pure font

-- | Configure glyph ranges with provided configuration, return a handle
-- and defer builder destructors, if needed.
setupRanges :: (MonadManaged m) => Ranges -> m (Maybe GlyphRanges)
setupRanges = \case
  RangesRaw ranges ->
    pure $ Just ranges
  RangesBuiltin builtin ->
    pure $ GlyphRanges.builtinSetup builtin
  RangesBuilder settings -> do
    built <- managed $ withRanges settings
    pure $ Just built

-- | Perform glyph ranges build based on provided configuration,
-- and execute a computation with built glyph ranges.
withRanges :: (MonadUnliftIO m) => RangesBuilderSetup -> (GlyphRanges -> m a) -> m a
withRanges (RangesBuilderSetup setup) fn =
  bracket acquire release execute
  where
    acquire = do
      builder <- GlyphRanges.new
      liftIO $ setup builder
      rangesVec <- GlyphRanges.buildRangesVector builder
      return (rangesVec, builder)

    release (rangesVec, builder) = do
      GlyphRanges.destroyRangesVector rangesVec
      GlyphRanges.destroy builder

    execute (rangesVec, _) =
      fn (GlyphRanges.fromRangesVector rangesVec)

-- | Configure font config with provided setup,
-- and execute a computation with built object.
-- return its handle and list of resource destructors.
withConfig :: (MonadUnliftIO m) => Maybe ConfigSetup -> (Maybe FontConfig -> m a) -> m a
withConfig mSetup action =
  case mSetup of
    Nothing ->
      action Nothing
    Just (ConfigSetup setup) ->
      bracket acquire (FontConfig.destroy) (action . Just)
      where
        acquire = do
          config <- FontConfig.new
          liftIO $ setup config
          return config

-- | Single Unicode character
addChar :: ImWchar -> RangesBuilderSetup
addChar char =
  RangesBuilderSetup \builder ->
    GlyphRanges.addChar builder char

-- | UTF-8 string
addText :: Text -> RangesBuilderSetup
addText str =
  RangesBuilderSetup \builder ->
    Text.withCString str (GlyphRanges.addText builder)

-- | Existing ranges (as is)
addRangesRaw :: GlyphRanges -> RangesBuilderSetup
addRangesRaw ranges =
  RangesBuilderSetup \builder ->
    GlyphRanges.addRanges builder ranges

-- | Existing ranges (through settings interface)
addRanges :: Ranges -> RangesBuilderSetup
addRanges = \case
  RangesRaw ranges ->
    addRangesRaw ranges
  RangesBuilder settings ->
    settings
  RangesBuiltin builtin ->
    addRangesRaw (GlyphRanges.getBuiltin builtin)

-- | TTF/OTF data ownership taken by the container ImFontAtlas (will delete memory itself).
--
-- By default, it is @true@
fontDataOwnedByAtlas :: Bool -> ConfigSetup
fontDataOwnedByAtlas value =
  ConfigSetup \fc ->
    FontConfig.setFontDataOwnedByAtlas fc (bool 0 1 value)

-- | Index of font within TTF/OTF file.
--
-- By default, it is @0@
fontNo :: Int -> ConfigSetup
fontNo value =
  ConfigSetup \fc ->
    FontConfig.setFontNo fc (fromIntegral value)

-- | Size in pixels for rasterizer
--
-- More or less maps to the resulting font height.
--
-- Implicitly set by @addFont...@ functions.
sizePixels :: Float -> ConfigSetup
sizePixels value =
  ConfigSetup \fc ->
    FontConfig.setSizePixels fc (CFloat value)

-- | Rasterize at higher quality for sub-pixel positioning.
--
-- Note: the difference between 2 and 3 is minimal so you can reduce this to 2 to save memory.
-- Read https://github.com/nothings/stb/blob/master/tests/oversample/README.md for details.
--
-- By default, it is @3@
oversampleH :: Int -> ConfigSetup
oversampleH value =
  ConfigSetup \fc ->
    FontConfig.setOversampleH fc (fromIntegral value)

-- | Rasterize at higher quality for sub-pixel positioning.
--
-- This is not really useful as we don't use sub-pixel positions on the Y axis.
--
-- By default, it is @1@
oversampleV :: Int -> ConfigSetup
oversampleV value =
  ConfigSetup \fc ->
    FontConfig.setOversampleV fc (fromIntegral value)

-- | Align every glyph to pixel boundary.
--
-- Useful if you are merging a non-pixel aligned font with the default font.
-- If enabled, you can set OversampleH/V to 1.
--
-- By default, it is @false@
pixelSnapH :: Bool -> ConfigSetup
pixelSnapH value =
  ConfigSetup \fc ->
    FontConfig.setPixelSnapH fc (bool 0 1 value)

-- | Extra spacing (in pixels) between glyphs.
--
-- Only X axis is supported for now.
--
-- By default, it is @0, 0@
glyphExtraSpacing :: (Float, Float) -> ConfigSetup
glyphExtraSpacing (x, y) =
  ConfigSetup \fc ->
    Foreign.with (ImVec2 x y) (FontConfig.setGlyphExtraSpacing fc)

-- | Offset all glyphs from this font input.
--
-- By default, it is @0, 0@
glyphOffset :: (Float, Float) -> ConfigSetup
glyphOffset (x, y) =
  ConfigSetup \fc ->
    Foreign.with (ImVec2 x y) (FontConfig.setGlyphOffset fc)

-- | Pointer to a user-provided list of Unicode range.
--
-- 2 values per range, inclusive. Zero-terminated list.
--
-- THE ARRAY DATA NEEDS TO PERSIST AS LONG AS THE FONT IS ALIVE.
--
-- By default, it is @NULL@
glyphRanges :: GlyphRanges -> ConfigSetup
glyphRanges value =
  ConfigSetup \fc ->
    FontConfig.setGlyphRanges fc value

-- | Minimum AdvanceX for glyphs.
--
-- Set Min to align font icons, set both Min/Max to enforce mono-space font.
--
-- By default, it is @0@
glyphMinAdvanceX :: Float -> ConfigSetup
glyphMinAdvanceX value =
  ConfigSetup \fc ->
    FontConfig.setGlyphMinAdvanceX fc (CFloat value)

-- | Maximum AdvanceX for glyphs.
--
-- By default, it is @FLT_MAX@.
glyphMaxAdvanceX :: Float -> ConfigSetup
glyphMaxAdvanceX value =
  ConfigSetup \fc ->
    FontConfig.setGlyphMaxAdvanceX fc (CFloat value)

-- | Merge into previous ImFont, so you can combine multiple inputs font into one ImFont.
--
-- e.g. ASCII font + icons + Japanese glyphs.
-- You may want to use @GlyphOffset.y@ when merging font of different heights.
--
-- By default, it is @false@
mergeMode :: Bool -> ConfigSetup
mergeMode value =
  ConfigSetup \fc ->
    FontConfig.setMergeMode fc (bool 0 1 value)

-- | Settings for custom font GlyphRanges.
--
-- THIS IS BUILDER IMPLEMENTATION DEPENDENT.
--
-- By default, it is @0@. Leave it so if unsure.
fontBuilderFlags :: Int -> ConfigSetup
fontBuilderFlags value =
  ConfigSetup \fc ->
    FontConfig.setFontBuilderFlags fc (fromIntegral value)

-- | Brighten (>1.0f) or darken (<1.0f) font output.
--
-- Brightening small fonts may be a good workaround to make them more readable.
--
-- By default, it is @1.0f@.
rasterizerMultiply :: Float -> ConfigSetup
rasterizerMultiply value =
  ConfigSetup \fc ->
    FontConfig.setRasterizerMultiply fc (CFloat value)

-- | Explicitly specify unicode codepoint of ellipsis character.
--
-- When fonts are being merged first specified ellipsis will be used.
--
-- By default, it is @-1@
ellipsisChar :: ImWchar -> ConfigSetup
ellipsisChar value =
  ConfigSetup \fc ->
    FontConfig.setEllipsisChar fc value