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

import Control.Monad (forM)
import Data.Char (generalCategory, GeneralCategory(..))

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

-- | 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 = forall {a} {a} {b} {a}.
(Integral a, Num a, Num b, Enum a) =>
(a, a) -> (a, b)
convert 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) = (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum a
c, 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
rforall 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 (forall a. a -> Maybe a
Just 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 forall a. Eq a => a -> a -> Bool
== Word32
prevCh forall a. Num a => a -> a -> a
+ Word32
sz Bool -> Bool -> Bool
&& Word8
prevWidth forall a. Eq a => a -> a -> Bool
== Word8
width
            then Maybe WidthTableRange
-> [WidthTableRange] -> [(Word32, Word8)] -> [WidthTableRange]
go (forall a. a -> Maybe a
Just (Word32 -> Word32 -> Word8 -> WidthTableRange
WidthTableRange Word32
prevCh (Word32
sz forall a. Num a => a -> a -> a
+ Word32
1) Word8
prevWidth)) [WidthTableRange]
finishedRanges [(Word32, Word8)]
rest
            else Maybe WidthTableRange
-> [WidthTableRange] -> [(Word32, Word8)] -> [WidthTableRange]
go (forall a. a -> Maybe a
Just (Word32 -> Word32 -> Word8 -> WidthTableRange
WidthTableRange Word32
c Word32
1 Word8
width)) (WidthTableRange
rforall a. a -> [a] -> [a]
:[WidthTableRange]
finishedRanges) [(Word32, Word8)]
rest

    in Maybe WidthTableRange
-> [WidthTableRange] -> [(Word32, Word8)] -> [WidthTableRange]
go 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. This works by using the
-- provided function to obtain the appropriate width for each character
-- in a wide range of Unicode code points, which on some platforms
-- may perform local terminal operations or may interact with system
-- libraries. Depending on how the provided width function works, this
-- may need to be run only in a terminal that is not actively controlled
-- by a Vty handle.
--
-- The character 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 Int) -> Char -> IO UnicodeWidthTable
buildUnicodeWidthTable :: (Char -> IO Int) -> Char -> IO UnicodeWidthTable
buildUnicodeWidthTable Char -> IO Int
charWidth Char
tableUpperBound = do
    [(Char, Int)]
pairs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
shouldConsider [Char
'\0'..Char
tableUpperBound]) forall a b. (a -> b) -> a -> b
$ \Char
i ->
        (Char
i,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> IO Int
charWidth Char
i

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