    {-# 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 :: String -> IO (Either String UnicodeWidthTable)
    readUnicodeWidthTable String
    path = ByteString -> Either String UnicodeWidthTable
    parseUnicodeWidthTable (ByteString -> Either String UnicodeWidthTable)
    -> IO ByteString -> IO (Either String UnicodeWidthTable)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> IO ByteString
    BSL.readFile String
    path

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

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

            Right (ByteString
    _, Int64
    _, UnicodeWidthTable
    table) ->
                UnicodeWidthTable -> Either String 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 :: String -> UnicodeWidthTable -> IO ()
    writeUnicodeWidthTable String
    path UnicodeWidthTable
    table = do
        let body :: ByteString
    body = Put -> ByteString
    runPut (UnicodeWidthTable -> Put
    tableV1Writer UnicodeWidthTable
    table)
        String -> ByteString -> IO ()
    BSL.writeFile String
    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
        magic <- Get Word32
    getWord32le

        when (magic /= widthTableMagic) $
            fail "Table magic number invalid"

        version <- getWord8

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

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

        let parseRange = do
                start <- Get Word32
    getWord32le
                size <- getWord32le
                cols <- getWord8
                return WidthTableRange { rangeStart = start
                                       , rangeSize = size
                                       , rangeColumns = cols
                                       }

        ranges <- forM [1..numRanges] $ const parseRange

        return UnicodeWidthTable { unicodeWidthTableRanges = 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 a. [a] -> 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