{-# LANGUAGE CPP #-}
module Graphics.Vty.UnicodeWidthTable.IO
  ( readUnicodeWidthTable
  , parseUnicodeWidthTable
  , writeUnicodeWidthTable
  )
where

import Control.Monad (when, forM)
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Lazy as BSL
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>))
#endif

import Graphics.Vty.UnicodeWidthTable.Types

-- | Load a binary unicode width table from the specified file.
--
-- This either returns a successfully parsed table or a table parsing
-- error message. This does not handle I/O exceptions.
readUnicodeWidthTable :: FilePath -> IO (Either String UnicodeWidthTable)
readUnicodeWidthTable :: FilePath -> IO (Either FilePath UnicodeWidthTable)
readUnicodeWidthTable FilePath
path = ByteString -> Either FilePath UnicodeWidthTable
parseUnicodeWidthTable (ByteString -> Either FilePath UnicodeWidthTable)
-> IO ByteString -> IO (Either FilePath UnicodeWidthTable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BSL.readFile FilePath
path

-- | Parse a binary unicode width table.
parseUnicodeWidthTable :: BSL.ByteString -> Either String UnicodeWidthTable
parseUnicodeWidthTable :: ByteString -> Either FilePath UnicodeWidthTable
parseUnicodeWidthTable ByteString
bs =
    case Get UnicodeWidthTable
-> ByteString
-> Either
     (ByteString, ByteOffset, FilePath)
     (ByteString, ByteOffset, UnicodeWidthTable)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, FilePath) (ByteString, ByteOffset, a)
runGetOrFail Get UnicodeWidthTable
tableParser ByteString
bs of
        Left (ByteString
_, ByteOffset
_, FilePath
msg) ->
            FilePath -> Either FilePath UnicodeWidthTable
forall a b. a -> Either a b
Left FilePath
msg

        -- Even if we parsed a table, leftover bytes indicate something
        -- could be wrong.
        Right (ByteString
remainingBytes, ByteOffset
_, UnicodeWidthTable
_) | Bool -> Bool
not (ByteString -> Bool
BSL.null ByteString
remainingBytes) ->
            FilePath -> Either FilePath UnicodeWidthTable
forall a b. a -> Either a b
Left (FilePath -> Either FilePath UnicodeWidthTable)
-> FilePath -> Either FilePath UnicodeWidthTable
forall a b. (a -> b) -> a -> b
$ FilePath
"Error: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ByteOffset -> FilePath
forall a. Show a => a -> FilePath
show (ByteString -> ByteOffset
BSL.length ByteString
remainingBytes) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
                   FilePath
" byte(s) left unconsumed"

        Right (ByteString
_, ByteOffset
_, UnicodeWidthTable
table) ->
            UnicodeWidthTable -> Either FilePath UnicodeWidthTable
forall a b. b -> Either a b
Right UnicodeWidthTable
table

-- | Write the unicode width table to the specified path.
--
-- This does not handle I/O exceptions.
writeUnicodeWidthTable :: FilePath -> UnicodeWidthTable -> IO ()
writeUnicodeWidthTable :: FilePath -> UnicodeWidthTable -> IO ()
writeUnicodeWidthTable FilePath
path UnicodeWidthTable
table = do
    let body :: ByteString
body = Put -> ByteString
runPut (UnicodeWidthTable -> Put
tableV1Writer UnicodeWidthTable
table)
    FilePath -> ByteString -> IO ()
BSL.writeFile FilePath
path ByteString
body

-- | Width table magic bytes for use in the binary format.
widthTableMagic :: Word32
widthTableMagic :: Word32
widthTableMagic = Word32
0xc1a9f7e0

tableParser :: Get UnicodeWidthTable
tableParser :: Get UnicodeWidthTable
tableParser = do
    Word32
magic <- Get Word32
getWord32le

    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
magic Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
widthTableMagic) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> Get ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Table magic number invalid"

    Word8
version <- Get Word8
getWord8

    case Word8
version of
        Word8
1 -> Get UnicodeWidthTable
tableV1Parser
        Word8
_ -> FilePath -> Get UnicodeWidthTable
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Table version invalid"

tableV1Parser :: Get UnicodeWidthTable
tableV1Parser :: Get UnicodeWidthTable
tableV1Parser = do
    Word32
numRanges <- Get Word32
getWord32le

    let parseRange :: Get WidthTableRange
parseRange = do
            Word32
start <- Get Word32
getWord32le
            Word32
size <- Get Word32
getWord32le
            Word8
cols <- Get Word8
getWord8
            WidthTableRange -> Get WidthTableRange
forall (m :: * -> *) a. Monad m => a -> m a
return WidthTableRange :: Word32 -> Word32 -> Word8 -> WidthTableRange
WidthTableRange { rangeStart :: Word32
rangeStart = Word32
start
                                   , rangeSize :: Word32
rangeSize = Word32
size
                                   , rangeColumns :: Word8
rangeColumns = Word8
cols
                                   }

    [WidthTableRange]
ranges <- [Word32]
-> (Word32 -> Get WidthTableRange) -> Get [WidthTableRange]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Word32
1..Word32
numRanges] ((Word32 -> Get WidthTableRange) -> Get [WidthTableRange])
-> (Word32 -> Get WidthTableRange) -> Get [WidthTableRange]
forall a b. (a -> b) -> a -> b
$ Get WidthTableRange -> Word32 -> Get WidthTableRange
forall a b. a -> b -> a
const Get WidthTableRange
parseRange

    UnicodeWidthTable -> Get UnicodeWidthTable
forall (m :: * -> *) a. Monad m => a -> m a
return UnicodeWidthTable :: [WidthTableRange] -> UnicodeWidthTable
UnicodeWidthTable { unicodeWidthTableRanges :: [WidthTableRange]
unicodeWidthTableRanges = [WidthTableRange]
ranges
                             }

tableV1Writer :: UnicodeWidthTable -> Put
tableV1Writer :: UnicodeWidthTable -> Put
tableV1Writer UnicodeWidthTable
table = do
    -- Magic bytes
    Word32 -> Put
putWord32le Word32
widthTableMagic

    -- Version
    Word8 -> Put
putWord8 Word8
1

    -- Number of ranges
    let ranges :: [WidthTableRange]
ranges = UnicodeWidthTable -> [WidthTableRange]
unicodeWidthTableRanges UnicodeWidthTable
table
    let numRanges :: Int
numRanges = [WidthTableRange] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [WidthTableRange]
ranges
    Word32 -> Put
putWord32le (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numRanges)

    -- Ranges
    let putRange :: WidthTableRange -> Put
putRange WidthTableRange
r = do
            Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ WidthTableRange -> Word32
rangeStart WidthTableRange
r
            Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ WidthTableRange -> Word32
rangeSize WidthTableRange
r
            Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ WidthTableRange -> Word8
rangeColumns WidthTableRange
r

    (WidthTableRange -> Put) -> [WidthTableRange] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ WidthTableRange -> Put
putRange [WidthTableRange]
ranges