{-# 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 c :: Char
c =
case Char -> GeneralCategory
generalCategory Char
c of
Control -> Bool
False
NotAssigned -> Bool
False
Surrogate -> Bool
False
_ -> Bool
True
charWidth :: Char -> IO Int
charWidth :: Char -> IO Int
charWidth c :: Char
c = do
String -> IO ()
forall r. PrintfType r => String -> r
printf "\r"
Char -> IO ()
putChar Char
c
Just (_, col :: Int
col) <- IO (Maybe (Int, Int))
getCursorPosition
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
col
mkRanges :: [(Char, Int)] -> [WidthTableRange]
mkRanges :: [(Char, Int)] -> [WidthTableRange]
mkRanges pairs :: [(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 (c :: a
c, i :: 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 Nothing finishedRanges :: [WidthTableRange]
finishedRanges [] = [WidthTableRange]
finishedRanges
go (Just r :: WidthTableRange
r) finishedRanges :: [WidthTableRange]
finishedRanges [] = WidthTableRange
rWidthTableRange -> [WidthTableRange] -> [WidthTableRange]
forall a. a -> [a] -> [a]
:[WidthTableRange]
finishedRanges
go Nothing finishedRanges :: [WidthTableRange]
finishedRanges ((c :: Word32
c, width :: Word8
width):rest :: [(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 1 Word8
width) [WidthTableRange]
finishedRanges [(Word32, Word8)]
rest
go (Just r :: WidthTableRange
r@(WidthTableRange prevCh :: Word32
prevCh sz :: Word32
sz prevWidth :: Word8
prevWidth)) finishedRanges :: [WidthTableRange]
finishedRanges ((c :: Word32
c, width :: Word8
width):rest :: [(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
+ 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 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
defaultUnicodeTableUpperBound :: Char
defaultUnicodeTableUpperBound :: Char
defaultUnicodeTableUpperBound = '\xe0000'
buildUnicodeWidthTable :: Char -> IO UnicodeWidthTable
buildUnicodeWidthTable :: Char -> IO UnicodeWidthTable
buildUnicodeWidthTable tableUpperBound :: 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 ['\0'..Char
tableUpperBound]) ((Char -> IO (Char, Int)) -> IO [(Char, Int)])
-> (Char -> IO (Char, Int)) -> IO [(Char, Int)]
forall a b. (a -> b) -> a -> b
$ \i :: 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
}