{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Graphics.Vty.UnicodeWidthTable.Install
  ( TableInstallException(..)
  , installUnicodeWidthTable
  , isCustomTableReady
  )
where

import Control.Monad (when, forM_)
import qualified Control.Exception as E
import GHC.Conc.Sync (withMVar)
import Control.Concurrent.MVar (MVar, newMVar)
import Data.Word (Word8, Word32)
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>))
#endif
import System.IO.Unsafe (unsafePerformIO)

import Graphics.Vty.UnicodeWidthTable.Types

-- | The lock used to make functions in this module thread-safe.
installLock :: MVar ()
{-# NOINLINE installLock #-}
installLock :: MVar ()
installLock = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO (IO (MVar ()) -> MVar ()) -> IO (MVar ()) -> MVar ()
forall a b. (a -> b) -> a -> b
$ () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()

-- | Returns True if and only if a custom table has been allocated and
-- marked as ready for use.
--
-- This function is thread-safe.
isCustomTableReady :: IO Bool
isCustomTableReady :: IO Bool
isCustomTableReady = IO Bool -> IO Bool
forall a. IO a -> IO a
withInstallLock (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
c_isCustomTableReady

withInstallLock :: IO a -> IO a
withInstallLock :: forall a. IO a -> IO a
withInstallLock IO a
act = MVar () -> (() -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
installLock ((() -> IO a) -> IO a) -> (() -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> () -> IO a
forall a b. a -> b -> a
const IO a
act

-- This is the size of the allocated custom character width table, in
-- character slots. It's important that this be large enough to hold all
-- possible Unicode character values. At the time of this writing, the
-- valid Unicode range is 0 - 0x10ffff, hence this value.
tableSize :: Int
tableSize :: Int
tableSize = Int
0x110000

-- | Exception type raised by 'installUnicodeWidthTable'.
data TableInstallException =
    TableInitFailure Int Int
    -- ^ The width table could not be initialized. Args: failure status,
    -- requested table size.
    | TableRangeFailure Int WidthTableRange
    -- ^ A code point range could not be configured. Args: failure
    -- status, offending range.
    | TableActivationFailure Int
    -- ^ The table could not be activated. Args: failure status.
    deriving (TableInstallException -> TableInstallException -> Bool
(TableInstallException -> TableInstallException -> Bool)
-> (TableInstallException -> TableInstallException -> Bool)
-> Eq TableInstallException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TableInstallException -> TableInstallException -> Bool
== :: TableInstallException -> TableInstallException -> Bool
$c/= :: TableInstallException -> TableInstallException -> Bool
/= :: TableInstallException -> TableInstallException -> Bool
Eq, Int -> TableInstallException -> ShowS
[TableInstallException] -> ShowS
TableInstallException -> String
(Int -> TableInstallException -> ShowS)
-> (TableInstallException -> String)
-> ([TableInstallException] -> ShowS)
-> Show TableInstallException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TableInstallException -> ShowS
showsPrec :: Int -> TableInstallException -> ShowS
$cshow :: TableInstallException -> String
show :: TableInstallException -> String
$cshowList :: [TableInstallException] -> ShowS
showList :: [TableInstallException] -> ShowS
Show)

instance E.Exception TableInstallException

-- | Install a custom unicode character width
-- table. Such tables are obtained with
-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable' and
-- 'Graphics.Vty.UnicodeWidthTable.IO.readUnicodeWidthTable'.
--
-- ALERT! This function is probably not what you want to use because
-- it is automatically called by 'Graphics.Vty.mkVty'. You will only
-- ever need to call this function if you want to use functions
-- in 'Graphics.Text.Width' without controlling the terminal with
-- 'Graphics.Vty.mkVty'.
--
-- This affects the behavior of the 'Graphics.Vty.Image.wcwidth'
-- function and functions that call it. It does so by
-- changing global state available to the C implementation
-- of 'Graphics.Vty.Image.wcwidth'. To ensure that your
-- program gets consistent results from evaluating calls to
-- 'Graphics.Vty.Image.wcwidth', the installation of a custom table
-- should be performed before you call 'Graphics.Vty.Image.wcwidth' in
-- your program.
--
-- This is best done at Vty startup, and if you use
-- 'Graphics.Vty.mkVty', that function calls this automatically based on
-- the Vty configuration's declared width tables. It is exposed as part
-- of the public API so that applications can call this as needed if
-- they don't want to control the terminal with 'mkVty' but do want to
-- make calls to 'Graphics.Vty.Image.wcwidth'.
--
-- It's also important to note that once a custom table has been
-- installed, it is permanent for the life of the process. No new table
-- can be installed, and the new custom table cannot be removed.
--
-- If this function fails for any reason -- if the table cannot be
-- installed or is invalid, or if a custom table already exists -- this
-- will raise a 'TableInstallException' exception.
--
-- This function is thread-safe.
installUnicodeWidthTable :: UnicodeWidthTable -> IO ()
installUnicodeWidthTable :: UnicodeWidthTable -> IO ()
installUnicodeWidthTable UnicodeWidthTable
table = IO () -> IO ()
forall a. IO a -> IO a
withInstallLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    initResult <- Int -> IO Int
initCustomTable Int
tableSize
    when (initResult /= 0) $
        E.throwIO $ TableInitFailure initResult tableSize

    forM_ (unicodeWidthTableRanges table) $ \WidthTableRange
r -> do
        result <- Word32 -> Word32 -> Word8 -> IO Int
setCustomTableRange (WidthTableRange -> Word32
rangeStart WidthTableRange
r)
                                      (WidthTableRange -> Word32
rangeSize WidthTableRange
r)
                                      (WidthTableRange -> Word8
rangeColumns WidthTableRange
r)

        when (result /= 0) $ do
            deallocateCustomTable
            E.throwIO $ TableRangeFailure result r

    actResult <- activateCustomTable
    when (actResult /= 0) $
        E.throwIO $ TableActivationFailure actResult

------------------------------------------------------------------------
-- C imports

foreign import ccall unsafe "vty_init_custom_table"
    initCustomTable :: Int -> IO Int

foreign import ccall unsafe "vty_set_custom_table_range"
    setCustomTableRange :: Word32 -> Word32 -> Word8 -> IO Int

foreign import ccall unsafe "vty_activate_custom_table"
    activateCustomTable :: IO Int

foreign import ccall unsafe "vty_custom_table_ready"
    c_isCustomTableReady :: IO Int

foreign import ccall unsafe "vty_deallocate_custom_table"
    deallocateCustomTable :: IO ()