    {-# 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 = (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. 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
        pairs <- [Char] -> (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) -> [Char] -> [Char]
    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

        return UnicodeWidthTable { unicodeWidthTableRanges = reverse $ mkRanges pairs
                                 }