{-# 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 :: 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
/= :: TableInstallException -> TableInstallException -> Bool
$c/= :: TableInstallException -> TableInstallException -> Bool
== :: TableInstallException -> TableInstallException -> Bool
$c== :: 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
showList :: [TableInstallException] -> ShowS
$cshowList :: [TableInstallException] -> ShowS
show :: TableInstallException -> String
$cshow :: TableInstallException -> String
showsPrec :: Int -> TableInstallException -> ShowS
$cshowsPrec :: Int -> 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
    Int
initResult <- Int -> IO Int
initCustomTable Int
tableSize
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
initResult Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TableInstallException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (TableInstallException -> IO ()) -> TableInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> TableInstallException
TableInitFailure Int
initResult Int
tableSize

    [WidthTableRange] -> (WidthTableRange -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (UnicodeWidthTable -> [WidthTableRange]
unicodeWidthTableRanges UnicodeWidthTable
table) ((WidthTableRange -> IO ()) -> IO ())
-> (WidthTableRange -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WidthTableRange
r -> do
        Int
result <- Word32 -> Word32 -> Word8 -> IO Int
setCustomTableRange (WidthTableRange -> Word32
rangeStart WidthTableRange
r)
                                      (WidthTableRange -> Word32
rangeSize WidthTableRange
r)
                                      (WidthTableRange -> Word8
rangeColumns WidthTableRange
r)

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
result Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            IO ()
deallocateCustomTable
            TableInstallException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (TableInstallException -> IO ()) -> TableInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> WidthTableRange -> TableInstallException
TableRangeFailure Int
result WidthTableRange
r

    Int
actResult <- IO Int
activateCustomTable
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
actResult Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TableInstallException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (TableInstallException -> IO ()) -> TableInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> TableInstallException
TableActivationFailure Int
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 ()