{-# LANGUAGE TupleSections #-}
module Graphics.Vty.UnicodeWidthTable.Query
  ( buildUnicodeWidthTable
  , defaultUnicodeTableUpperBound
  )
where

import Control.Monad (forM)
import Data.Char (generalCategory, GeneralCategory(..))
import System.Console.ANSI (getCursorPosition)
import Text.Printf (printf)

import Graphics.Vty.UnicodeWidthTable.Types

shouldConsider :: Char -> Bool
shouldConsider :: Char -> Bool
shouldConsider Char
c =
    case Char -> GeneralCategory
generalCategory Char
c of
        GeneralCategory
Control     -> Bool
False
        GeneralCategory
NotAssigned -> Bool
False
        GeneralCategory
Surrogate   -> Bool
False
        GeneralCategory
_           -> Bool
True

charWidth :: Char -> IO Int
charWidth :: Char -> IO Int
charWidth Char
c = do
    String -> IO ()
forall r. PrintfType r => String -> r
printf String
"\r"
    Char -> IO ()
putChar Char
c
    Just (Int
_, Int
col) <- IO (Maybe (Int, Int))
getCursorPosition
    Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
col

-- | Convert a sequence of character/width pairs into a list of
-- run-length encoded ranges. This function assumes the pairs come
-- sorted by character ordinal value. It does not require that the
-- character range is fully covered by the sequence.
--
-- The result of this function is a list of ranges in reverse order
-- relative to the input sequence.
mkRanges :: [(Char, Int)] -> [WidthTableRange]
mkRanges :: [(Char, Int)] -> [WidthTableRange]
mkRanges [(Char, Int)]
pairs =
    let convertedPairs :: [(Word32, Word8)]
convertedPairs = (Char, Int) -> (Word32, Word8)
forall a a b a.
(Integral a, Num a, Num b, Enum a) =>
(a, a) -> (a, b)
convert ((Char, Int) -> (Word32, Word8))
-> [(Char, Int)] -> [(Word32, Word8)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Char, Int)]
pairs
        convert :: (a, a) -> (a, b)
convert (a
c, a
i) = (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Enum a => a -> Int
fromEnum a
c, a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i)

        go :: Maybe WidthTableRange
-> [WidthTableRange] -> [(Word32, Word8)] -> [WidthTableRange]
go Maybe WidthTableRange
Nothing [WidthTableRange]
finishedRanges [] = [WidthTableRange]
finishedRanges
        go (Just WidthTableRange
r) [WidthTableRange]
finishedRanges [] = WidthTableRange
rWidthTableRange -> [WidthTableRange] -> [WidthTableRange]
forall a. a -> [a] -> [a]
:[WidthTableRange]
finishedRanges

        go Maybe WidthTableRange
Nothing [WidthTableRange]
finishedRanges ((Word32
c, Word8
width):[(Word32, Word8)]
rest) =
            Maybe WidthTableRange
-> [WidthTableRange] -> [(Word32, Word8)] -> [WidthTableRange]
go (WidthTableRange -> Maybe WidthTableRange
forall a. a -> Maybe a
Just (WidthTableRange -> Maybe WidthTableRange)
-> WidthTableRange -> Maybe WidthTableRange
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> Word8 -> WidthTableRange
WidthTableRange Word32
c Word32
1 Word8
width) [WidthTableRange]
finishedRanges [(Word32, Word8)]
rest

        go (Just r :: WidthTableRange
r@(WidthTableRange Word32
prevCh Word32
sz Word8
prevWidth)) [WidthTableRange]
finishedRanges ((Word32
c, Word8
width):[(Word32, Word8)]
rest) =
            if Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
prevCh Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
sz Bool -> Bool -> Bool
&& Word8
prevWidth Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
width
            then Maybe WidthTableRange
-> [WidthTableRange] -> [(Word32, Word8)] -> [WidthTableRange]
go (WidthTableRange -> Maybe WidthTableRange
forall a. a -> Maybe a
Just (Word32 -> Word32 -> Word8 -> WidthTableRange
WidthTableRange Word32
prevCh (Word32
sz Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1) Word8
prevWidth)) [WidthTableRange]
finishedRanges [(Word32, Word8)]
rest
            else Maybe WidthTableRange
-> [WidthTableRange] -> [(Word32, Word8)] -> [WidthTableRange]
go (WidthTableRange -> Maybe WidthTableRange
forall a. a -> Maybe a
Just (Word32 -> Word32 -> Word8 -> WidthTableRange
WidthTableRange Word32
c Word32
1 Word8
width)) (WidthTableRange
rWidthTableRange -> [WidthTableRange] -> [WidthTableRange]
forall a. a -> [a] -> [a]
:[WidthTableRange]
finishedRanges) [(Word32, Word8)]
rest

    in Maybe WidthTableRange
-> [WidthTableRange] -> [(Word32, Word8)] -> [WidthTableRange]
go Maybe WidthTableRange
forall a. Maybe a
Nothing [] [(Word32, Word8)]
convertedPairs

-- The uppermost code point to consider when building Unicode width
-- tables.
defaultUnicodeTableUpperBound :: Char
defaultUnicodeTableUpperBound :: Char
defaultUnicodeTableUpperBound = Char
'\xe0000'

-- | Construct a unicode character width table by querying the terminal
-- connected to stdout. This works by emitting characters to stdout
-- and then querying the terminal to determine the resulting cursor
-- position in order to measure character widths. Consequently this will
-- generate a lot of output and may take a while, depending on your
-- system performance. This should not be run in a terminal while it is
-- controlled by Vty.
--
-- The argument specifies the upper bound code point to test when
-- building the table. This allows callers to decide how much of the
-- Unicode code point space to scan when building the table.
--
-- This does not handle exceptions.
buildUnicodeWidthTable :: Char -> IO UnicodeWidthTable
buildUnicodeWidthTable :: Char -> IO UnicodeWidthTable
buildUnicodeWidthTable Char
tableUpperBound = do
    [(Char, Int)]
pairs <- String -> (Char -> IO (Char, Int)) -> IO [(Char, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
shouldConsider [Char
'\0'..Char
tableUpperBound]) ((Char -> IO (Char, Int)) -> IO [(Char, Int)])
-> (Char -> IO (Char, Int)) -> IO [(Char, Int)]
forall a b. (a -> b) -> a -> b
$ \Char
i ->
        (Char
i,) (Int -> (Char, Int)) -> IO Int -> IO (Char, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> IO Int
charWidth Char
i

    UnicodeWidthTable -> IO UnicodeWidthTable
forall (m :: * -> *) a. Monad m => a -> m a
return UnicodeWidthTable :: [WidthTableRange] -> UnicodeWidthTable
UnicodeWidthTable { unicodeWidthTableRanges :: [WidthTableRange]
unicodeWidthTableRanges = [WidthTableRange] -> [WidthTableRange]
forall a. [a] -> [a]
reverse ([WidthTableRange] -> [WidthTableRange])
-> [WidthTableRange] -> [WidthTableRange]
forall a b. (a -> b) -> a -> b
$ [(Char, Int)] -> [WidthTableRange]
mkRanges [(Char, Int)]
pairs
                             }